Статьи Королевства Дельфи
Запросы к микшеру.
UINT mixerGetNumDevs(VOID)возвращает количество микшеров, представленных в системе. Полезна, если в системе уставлено более одной звуковой платы.
MMRESULT mixerGetDevCaps(UINT_PTR uMxId, LPMIXERCAPS pmxcaps, UINT cbmxcaps)
возвращает характеристики указанного микшера
uMxId -- идентификатор или обработчик открытого микшера
pmxcaps -- указатель на структуру MIXERCAPS в которой возвращается информация
cbmxcaps -- размер в байтах структуры MIXERCAPS
MIXERCAPS
структура, описывающая характеристики микшера.
typedef struct { WORD wMid; WORD wPid; MMVERSION vDriverVersion; CHAR szPname[MAXPNAMELEN]; DWORD fdwSupport; DWORD cDestinations; } MIXERCAPS; Для нас практически интересен только элемент cDestinations -- число аудиолиний-приемников, доступных из микшера. Все микшеры должны поддерживать хотя бы одну линию-приемник и возвращать ненулевое значение в этом поле. Значение поля используется при назначении индекса линии-приемника в структуре MIXERLINE в поле dwDestination и изменяется от 0 до cDestinations-1. В поле szPname у нас есть текстовое название микшера, если кому-то нужно.
MMRESULT mixerGetID( HMIXEROBJ hmxobj, UINT_PTR *puMxId, DWORD fdwId );
возвращает идентификатор микшера, соответствующего заданному обработчику.
hmxobj -- обработчик микшера, для которого определяется идентификатор.
puMxId -- указатель на переменную, в которую возвращяется идентификатор.
fdwId -- флаг, определяющий, каким образом понимать hmxobj
Управление микшером.
MMRESULT mixerClose( HMIXER hmx );закрывает заданный микшер.
hmx -- обработчик микшера, который был возвращен функцией mixerOpen.
MMRESULT mixerOpen( LPHMIXER phmx, UINT uMxId, DWORD_PTR dwCallback, DWORD_PTR dwInstance, DWORD fdwOpen );
открывает заданный микшер и гарантирует, что он не будет удален, пока приложение не закроет обработчик микшера.
phmx -- указатель на обработчик микшера.
uMxId -- идентификатор открываемого микшера
dwCallback -- обработчик окна, которое будет получать сообщения об изменении состояния ассоциированных элементов управления аудолиний. Должен быть 0 если не используется.
dwInstance -- пользовательские данные для функции обратного вызова.
fdwOpen -- флаг открытия микшера.
Заметим, что если fdwOpen установить в значение MIXER_OBJECTF_MIXER, то uMxId можно задавать от 0 и до числа микшеров mixerGetNumDevs()-1.
Уровень 2. Аудиолиния. Структуры и функции, предназначенные для работы с аудиолиниями.
Что такое MapInfo и с чем его едят? Краткое предисловие.
Сейчас нам доступны огромные объемы информации. Данные хранятся в электронных таблицах, отчетности о торговле и маркетинге. Масса информации о клиентах, магазинах, персонале, оборудовании и ресурсах находится на бумаге и в памяти компьютеров Тематическая Карта, содержащая слой диапазонов (процент занятости) и круговые диаграммы (производство с/х продуктов) Почти все эти данные имеют географическую составляющую. По разным оценкам до 85 процентов всех баз данных содержат, какую либо географическую информацию.При этой оценке учитывались объемы данных, содержащие адреса, имена городов, названия областей, государств, почтовые индексы и даже номера телефонов, включая коды удаленного доступа и добавочные номера. Настольная картография позволит Вашему компьютеру не просто обрабатывать данные, а быстро и наглядно представлять их, используя географические компоненты данных, чтобы Вы могли уловить их общий смысл, отражаемый на картах.
Что такое порт.
Известно что в компьютере очень много собрано различных устройств , возникает вопрос как операционная система общается с ними. Для этого и служит порт, то есть эта «дверь» через которую программа (операционная система) может управлять данным устройством (считывать данные, заносить их).Причем я разделяю порты на две категории (это чисто мое разделение) - порты общеизвестные (COM LPT) и порты внутренние ,служащие для связи с внутренними устройствами ЭВМ.Генерация кода
На основе исходного представления, которое формулирует технолог, нужно сгенерировать код для компиляции. Исходное представление может быть любым, в простейшем случае - это обычный текст. В процессе генерации кода наибольшее внимание нужно уделить диагностике ошибок. То есть, ошибки желательно выявить во время генерации кода и генерировать уже синтаксически правильный код. Для этого можно использовать любые доступные методы, вплоть до синтаксических анализаторов с рекурсивным спуском - такие анализаторы достаточно просты и описаны во многих книгах, например у Бьерна Страуструпа в "Язык программирования C++" (Третье издание). Если есть возможность, то желательно контролировать также семантическую правильность. Далее я буду рассматривать только те моменты, которые являются общими для всех задач без учета их специфики.Генерировать исходный текст можно любым способом, например, просто посылая строки текста в файл. Более удобный способ, как мне кажется, это направление текста в строко-ориентированный поток. Такой поток предоставляет дополнительное удобство при диагностике ошибок. Библиотека DccUsing содержит два потоковых класса: TFileCompileOut и TStringCompileOut, которые порождаются от TCompileOut. Классы очень просты, их реализацию можно посмотреть в исходном файле библиотеки, поэтому я дам только обзор. Базовый класс имеет методы:
public procedure IncLevel; procedure DecLevel; procedure AddSpace; procedure AddLine(const aLine: String); procedure AddLines(const aLines: array of String); procedure AddFile(const aFileName: String); procedure AddLineTemplate(const aLine: String; const aArgs: array of String); procedure AddLinesTemplate(const aLines, aArgs: array of String); procedure AddFileTemplate(const aFileName: String; const aArgs: array of String); procedure AddPoint(aPoint: Integer); function FindPoint(aLine: Integer): Integer; property Level: Integer read FLevel; property LinesCount: Integer read FLinesCount;
Первые три метода позволяют управлять форматированием кода. Хотя форматирование совсем не обязательно (код никто не читает), но дает удобства при отладке, а, кроме того, мне нравится, когда программа выглядит эстетично. IncLevel увеличивает отступ текста, DecLevel уменьшает, а AddSpace добавляет в поток пустую строку. Два следующих метода добавляют в поток соответственно строку и массив строк, а метод AddFile - весь указанный файл. Свойства позволяют узнать текущий уровень отступа и текущее число строк в потоке. Назначение методов AddPoint и FindPoint будет объяснено в разделе диагностики ошибок.
Методы AddLineTemplate, AddLinesTemplate и AddFileTemplate более сложны, чем предыдущие методы, представляют собой простые макропроцессоры и позволяют параметризовать генерируемый текст. Параметризующие аргументы - это массив строк, которые заменяют метасимволы в исходном тексте шаблона. Метасимволы выглядят так: {{X}}, где Х - это порядковый номер аргумента, начиная от 1. Макроподстановка производится без всякого учета лексики. Поэтому можно параметризовать все что угодно - идентификаторы, строки, комментарии, операторы и т.д. Например, если шаблон текста таков:
const tFunc: array[0..5] of String = ( 'function {{1}}.SortProc{{2}}(const a1, a2: {{2}}): Integer;', 'begin', ' if a2 > a1 then result := 1', ' else if a2 = a1 then result := 0', ' else result := -1;', 'end;' ); то при использовании
c.AddLinesTemplate(tFunc,['TTestClass1','Integer']); мы получим такой результат:
function TTestClass1.SortProcInteger(const a1, a2: Integer): Integer; begin if a2 > a1 then result := 1 else if a2 = a1 then result := 0 else result := -1; end; а при использовании
c.AddLinesTemplate(tFunc,['TTestClass2','String']); такой:
function TTestClass2.SortProcString(const a1, a2: String): Integer; begin if a2 > a1 then result := 1 else if a2 = a1 then result := 0 else result := -1; end;
Наследуемые классы переопределяют абстрактную процедуру записи строки в поток и имеют специфические методы. Класс TFileCompileOut специализируется на построчном выводе в файл:
public constructor Create(const aFileName: String); destructor Destroy; override; property FileName: String read FFileName;
Конструктор принимает имя файла и открывает файл на чтение, а деструктор закрывает файл.
Класс TStringCompileOut хранит генерируемый текст в памяти:
public procedure Clear; procedure SaveToFile(const aFileName: String); procedure SaveToOut(aOut: TCompileOut); property Capacity: Integer ... property Items[aIndex: Integer]: String ... default;
Методы класса позволяют очистить поток, сохранить поток в файле и добавить его к другому потоку. Свойства позволяют изменить резервируемый объем памяти для списка строк и получить доступ на запись и чтение строк по индексу. Общее число строк определяет наследуемое свойство LinesCount. Примеры использования этих классов смотрите в DccExamples.pas.
Отметим, что часть неизменяемого или шаблонного кода может быть заготовлена заранее, располагаться в файлах и объединяться в нужных местах результирующего кода с помощью AddFile и AddFileTemplate. По ходу генерации кода может быть создано несколько потоков - для деклараций переменных и констант, деклараций и реализаций классов и так далее. После просмотра всей задачи, сформулированной технологом, эти потоки сшиваются в один результирующий поток. Для частных потоков можно использовать строковую реализацию, а для результирующего потока - файловую.
Интеграция инструментальных панелей Maplnfo краткий вводный курс.
Вы не можете переподчинить стандартные инструментальные панели MapInfo. Если Вы хотите, чтобы Ваша клиентская программа имела такие панели вы должны сами создать панели и кнопки на Delphi (например используя Tpanel и Tbutton) и их обработчике посылать специальные команды MapInfo для того что-бы MapInfo включало или переключала режимы работы (например с выбора объекта на перемещения окна карты (ладошка)).Если Вы хотите, чтобы кнопка панели эмулировала стандартную кнопку MapInfo, используйте метод MapInfo Run Menu Command.
Например в обработчике OnClick пропишите следующею команду KDMapInfoServer1.ExecuteCommandMapBasic('Run Menu Command 1702',[]); Когда пользователь нажмет на эту кнопку, программа вызывовет метод MapInfo - Run Menu Command, который активизирует инструмент под номером 1702 (инструмент перемещение карты "рука" ).
"Магический" номер 1702 ссылается на инструмент "рука" служащий для перемещения (сдвига) карты.
Вместо того, чтобы использовать такие числа. Вы можете использовать идентификаторы, более понятные в тексте программы. MapBasic определяет стандартный идентификатор M_TOOLS_RECENTER который имеет значение 1702. Таким образом, этот пример можно записать так: KDMapInfoServer1.ExecuteCommandMapBasic('Run Menu Command %S', [M_TOOLS_RECENTER]); Использование идентификаторов (типа M_TOOLS_RECENTER) делает Вашу программу более читательной, но перед использование вы должны включить в программу (в Uses) соответствующий заголовочный файл MapBasic. Для Delphi я положил файл Global.pas (содержимое файла опубликовано в приложении 1).
В следующей таблице приведены кратко идентификаторы основных инструментальных кнопок MapInfo (для более побробной информации смотрите документацию по MapBasic).
| Кнопки панели Операции | Номер | Идентификатор | Прим. |
| Выбор | 1701 | М_TOOLS_SELECTOR | Панель ОПЕРАЦИИ |
| Выбор в прямоугольнике | 1722 | M_TOOLS_SEARCH_RECT | Панель ОПЕРАЦИИ |
| Выбор в круге | 1703 | M_TOOLS_SEARCH_RADIUS | Панель ОПЕРАЦИИ |
| Выбор в области | 1704 | M_TOOLS_SEARCH_BOUNDARY | Панель ОПЕРАЦИИ |
| Увеличивающая лупа | 1705 | M_TOOLS_EXPAND | Панель ОПЕРАЦИИ |
| Уменьшающая лупа | 1706 | M_TOOLS_SHRINK | Панель ОПЕРАЦИИ |
| Ладошка (рука) | 1702 | M_TOOLS_RECENTER | Панель ОПЕРАЦИИ |
| Информация | 1707 | M_TOOLS_PNT_QUERY | Панель ОПЕРАЦИИ |
| Подпись | 1708 | M_TOOLS_LABELER | Панель ОПЕРАЦИИ |
| Линейка | 1710 | M_TOOLS_RULER | Панель ОПЕРАЦИИ |
| Переноска | 1734 | M_TOOLS_DRAGWINDOW | Панель ОПЕРАЦИИ |
| Символ | 1711 | M_TOOLS_POINT | Панель ПЕНАЛ |
| Линия | 1712 | M_TOOLS_LINE | Панель ПЕНАЛ |
| Полилиния | 1713 | M_TOOLS_POLYLINE | Панель ПЕНАЛ |
| Дуга | 1716 | M_TOOLS_ARC | Панель ПЕНАЛ |
| Полигон | 1714 | M_TOOLS_POLYGON | Панель ПЕНАЛ |
| Эллипс | 1715 | M_TOOLS_ELLIPSE | Панель ПЕНАЛ |
| Прямоугольник | 1717 | M_TOOLS_RECTANGLE | Панель ПЕНАЛ |
| Прямоугольник скругленный | 1718 | M_TOOLS_ROUNDEDRECT | Панель ПЕНАЛ |
| Текст| | 1709 | M_TOOLS_TEXT | Панель ПЕНАЛ |
| Рамка | 1719 | M_TOOLS_FRAME | Панель ПЕНАЛ |
Довольно типичным практическим примером проблемы
Довольно типичным практическим примером проблемы решаемой с использованием динамических структур является сортировка данных, получаемых по запросу из иерархической таблицы реляционной базы данных. Требование отсортированности по алфавиту в пределах уровня иерархии без нарушения иерархического порядка исключает чисто SQL-ные решения. Естественным решением в этом случае было бы накопление данных в иерархической структуре в памяти, с последующей их сортировкой. Причём, учитывая большой объем данных хотелось бы сделать это с максимальной эффективностью и минимальными накладными расходами. Но в стандартном наборе контейнеров Delphi кроме "универсальных" TList и TStringList ничего нет ! Между тем мир программистов C++ не знает забот: у них есть STL и прочие прекрасные вещи. Попробуем и мы, не расчитывая на благодеяния фирмы Borland сделать что-нибудь подобное.Получение информации об аудиолинии
MMRESULT mixerGetLineInfo ( HMIXEROBJ hmxobj, LPMIXERLINE pmxl, DWORD fdwInfo );Возвращает информацию о заданной аудиолинии.
hmxobj -- обработчик микшера, управляющего заданной аудиолинией.
pmxl -- указатель на структуру MIXERLINE, которая заполняется информацие об аудиолинии. В элементе cbStruct структуры должен быть ее размер в байтах.
fdwInfo -- флаги, определяющие возвращаемую информацию.
Для нас важны три флага
MIXER_OBJECTF_HMIXER -- параметр hmxobj является обработчиком микшера, открытого функцией mixerOpen.
MIXER_GETLINEINFOF_DESTINATION -- параметр pmxl возвращает информацию о линии-приемнике с индексом, заданным в поле dwDestination структуры MIXERLINE. Этот индекс меняется от 0 до cDestinations-1 из MIXERCAPS.
MIXER_GETLINEINFOF_SOURCE -- параметр pmxl возвращает информацию о линии-источнике с индексом, заданным в поле dwDestination структуры MIXERLINE. Этот индекс меняется от 0 до cDestinations-1 из MIXERCAPS.
Функции вызываем в основном с комбинацией флагов MIXER_OBJECTF_HMIXER or MIXER_GETLINEINFOF_DESTINATION или MIXER_OBJECTF_HMIXER or MIXER_GETLINEINFOF_SOURCE.
Поясню подробнее о получении информации о линиях-приемниках и линиях-источниках. Сколько линий-приемников узнаем из cDestinations структуры MIXERCAPS. Информацию о линии-приемнике узнаем вызовом mixerGetLineInfo с флагом MIXER_GETLINEINFOF_DESTINATION и установленным индексом линии в поле dwDestination структуры MIXERLINE.
Каждая линия-приемник может иметь несколько линий-источников. Поэтому сколько линий-источников для каждой линии-приемника, узнаем при вызове mixerGetLineInfo с флагом MIXER_GETLINEINFOF_DESTINATION из поля cConnections структуры MIXERLINE, т.е. когда получали информацию о линии-приемнике.
И, наконец, информацию о линии-источнике узнаем вызовом mixerGetLineInfo с флагом MIXER_GETLINEINFOF_SOURCE и установленными индексами линии-приемника в поле dwDestination и линии-источника в поле dwSource структуры MIXERLINE. Индекс dwSource меняется от 0 до cConnections-1 из MIXERLINE для линии-приемника. Вот такая вот система, потеряться легко.
MIXERLINE
Структура, описывающая состояние и метрики аудиолинии.
typedef struct { DWORD cbStruct; DWORD dwDestination; DWORD dwSource; DWORD dwLineID; DWORD fdwLine; DWORD dwUser; DWORD dwComponentType; DWORD cChannels; DWORD cConnections; DWORD cControls; CHAR szShortName[MIXER_SHORT_NAME_CHARS]; CHAR szName[MIXER_LONG_NAME_CHARS]; struct { DWORD dwType; DWORD dwDeviceID; WORD wMid; WORD wPid; MMVERSION vDriverVersion; CHAR szPname[MAXPNAMELEN]; } Target; } MIXERLINE;
cbStruct -- размер структуры MIXERLINE в байтах.
dwDestination -- индекс линии-приемника. Изменяется от 0 до cDestinations-1 из MIXERCAPS. (вызов mixerGetDevCaps). Когда mixerGetLineInfo вызывается с флагом MIXER_GETLINEINFOF_DESTINATION, то в этом поле указывается индекс опрашиваемой линии. При этом dwSource должен быть равен 0. Когда используется флаг MIXER_GETLINEINFOF_SOURCE в поле dwSource должен быть индекс опрашиваемой линии-источника, ассоциированной с линией-премником, заданной в dwDestination.
dwSource -- индекс линии-приемника, асоциированной с линией-источником с индексом в dwDestination. Работает с флагом MIXER_GETLINEINFOF_SOURCE и изменяется от 0 до cConnections-1 из структуры, полученной для линии-приемника.
dwLineID -- идентификатор линии.
fdwLine -- флаги статуса и поддерживаемых функций для аудиолинии.
dwUser -- только для особо одаренных. Можно игнорировать.
dwComponentType -- тип аудиолинии. Их много всяких, но нам интересней:
MIXERLINE_COMPONENTTYPE_SRC_LINE -- линейный вход
MIXERLINE_COMPONENTTYPE_SRC_COMPACTDISC -- вход с компакт-диска
MIXERLINE_COMPONENTTYPE_DST_SPEAKERS -- выход на колонки
MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE-- микрофон
MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT -- стандартный вход, т.е. источник wave-данных (из файла, например) MIXERLINE_COMPONENTTYPE_DST_WAVEIN -- линия-приемник для записи в файл, например.
В общем, с этими типами дело темное, надо эксперименты устраивать, т.к. у меня драйвер для одной карточки безбожно врал и обзывал линии как хотел. Хотя, если найти соответствие, все работало как часы. Так что если в этом месте ошибочка вышла, простите.
cChannels -- максимальное число раздельных каналов. Это 2 для стерео, 1 для моно. Для навороченных карт может быть больше. cConnections -- число соединений для аудиолинии. Используется только для линий-приемников, а для линий-источников всегда 0. Логично. Прием ведем с многих направлений.
cControls -- число элементов управления (контролов) ассоциированных с данной линией, неважно, приемник или источник. Ели таких нет, то 0.
szShortName -- краткое наименование аудиолинии
szName -- полное наименование аудиолинии.
Target -- структура, описывающая микшер и возвращающая др. данные. Честно говоря, ни разу не использовал. Пропускаю из-за сомнительной ценности.
Уровень 3. Элемент управления (контрол). Структуры и функции, предназначенные для работы с элементами управления аудиолинии.
Что такое интегрированная картография и какой нам от нее смысл.
Интегрированная картография позволяет управлять пакетом MapInfo, используя языки программирования отличные от MapBasic. Например если вам хорошо знакомо программирование на языке Visual Basic или С++ или Delphi (о чем и пойдет речь далее...) вы можете включить окно MapInfo в ваше приложение, тем самым обеспечивая интеграцию пакета MapInfo с логикой (бизнес-правилами) вашей программы.
Причем основную работу по поддержанию векторных карт берет на себя MapInfo (MapBasic) а вы можете создовать назначать обработчики и механизмы взаимодействия не свойственные MapBasic а также те механизмы которые MapBasic не поддерживает напрямую (например обновление карты по интернету,съем информации с датчиков на территории и обновление на карте ит.п.)
На Рисунок 2 как раз представлен пример интегрированной картографии встроенной в мой проект на Delphi.
Итак приступим : в цикле статей будут рассмотрены следующие вещи
Компиляция
После того, как исходный код создан, требуется его откомпилировать. Компилятор dcc32 замечательно подходит для этой роли - он очень быстрый, качественный и объединяет в себе все, что необходимо для построения exe-файлов, dll-библиотек и пакетов. Размер файла dcc32.exe (версия 12.0, из Delphi 5) всего 545 Кб, ранние версии имеют еще меньший размер. К нему нужно добавить только три файла - rlink32.dll, sysinit.dcu и system.dcu (это минимум). Компилятор и указанные файлы можно разместить в подкаталоге прикладной программы, например, bin. Генерировать текст целесообразно в подкаталоге компилятора, например, bin\pas, чтобы использовать короткие пути файлов и не засорять каталог компилятора.Для вызова dcc32.exe в библиотеке DccUsing определена функция ExecDcc32. Она устанавливает текущий каталог, создает файл для перехвата ошибок компиляции, вызывает компилятор, дожидается завершения компиляции и определяет наличие ошибок.
function ExecDcc32(const aDccDir, aOptions, aProjectPath, aErrorPath: String; aCheckPaths: Boolean = False): Boolean;
Функция принимает аргументы: aDccDir - каталог, в котором находится компилятор Dcc32, aOptions - опции компилятора (рекомендации по их использованию смотрите в файле DccUsing.pas), aProjectPath - путь файла проекта (обычно dpr), aErrorPath - путь файла, куда будут направляться сообщения об ошибках компиляции. Необязательный аргумент aCheckPaths позволяет разрешить или запретить контроль наличия каталога и файла dcc32.exe. Функция возвращает True, если компиляция была успешной и False в противном случае. Предупреждения (hints и warnings) ошибками не считаются - их выводом можно управлять с помощью опций -H и -W. Опуская детали, рассмотрим немного подробнее эту функцию:
// сохранение текущего каталога и установка нового CurDir := GetCurrentDir; if not SetCurrentDir(DccDir) then raise Exception.Create(SCantChangeDir + DccDir); try hStdOut := INVALID_HANDLE_VALUE; try // установки атрибутов безопасности with SecurAtt do begin nLength := SizeOf(SecurAtt); lpSecurityDescriptor := nil; // разрешить наследование дочернему процессу bInheritHandle := BOOL(True); end; // создание файла, в который будут направляться ошибки hStdOut := CreateFile(PChar(aErrorPath), GENERIC_WRITE, 0, @SecurAtt, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if hStdOut = INVALID_HANDLE_VALUE then raise Exception.Create(SCantCreateFile + aErrorPath); // заполнение структуры, специфицирующей создание процесса ZeroMemory(@StartupInfo, SizeOf(StartupInfo)); with StartupInfo do begin cb := SizeOf(StartupInfo); // скрывать окно компилятора и наследовать потоки ввода-вывода dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; wShowWindow := SW_HIDE; hStdOutput := hStdOut; end; // создать и стартовать процесс компилятора s := 'dcc32.exe ' + aOptions + ' ' + aProjectPath; if not CreateProcess('dcc32.exe', PChar(s), @SecurAtt, @SecurAtt, BOOL(True), 0, nil, PChar(DccDir), StartupInfo, ProcessInfo) then raise Exception.Create(SCantCreateProcess + 'dcc32.exe'); // ждать завершение компиляции неопределенное время WaitForSingleObject(ProcessInfo.hProcess, INFINITE); // получить результат компиляции ResultCode := 0; GetExitCodeProcess(ProcessInfo.hProcess, ResultCode); result := ResultCode = 0; finally // закрыть файл ошибок if hStdOut <> INVALID_HANDLE_VALUE then CloseHandle(hStdOut); end; finally // восстановить прежний каталог по умолчанию SetCurrentDir(CurDir); end;
Установка каталога компилятора, как текущего, позволяет не заботиться о мелочах, связанных с назначением путей. Компилятор направляет сообщения об ошибках в стандартный файл вывода. Для его перехвата создаем свой файл, дескриптор которого передаем компилятору. Для того, чтобы процесс компилятора мог наследовать дескриптор открытого файла, устанавливаем его атрибут наследования. При заполнении структуры StartupInfo указываем, что окно компилятора должно быть скрытым и порождаемый процесс должен наследовать стандартные потоки ввода-вывода. Атрибуты безопасности, передаваемые функции создания процесса, нужны для правильной работы в NT, в Windows 95-98 их можно было бы опустить. Функция CreateProcess сохраняет параметры процесса в структуре ProcessInfo - мы используем дескриптор процесса, чтобы передать его функции ожидания системного события - в данном случае, завершения процесса. С помощью GetExitCodeProcess получаем значение, которое возвращает компилятор. Если компиляция была успешной, то возвращается 0, иначе - ненулевое значение. Операции закрытия файла ошибок и восстановления предыдущего каталога произойдут независимо от возможных исключительных ситуаций по ходу функции ExecDcc32.
Компилятору, вместе с исходным файлом (файлами), нужно также передать файл проекта (dpr) и уточнить в опциях, что же будет результатом компиляции. Возможных вариантов много - GUI или консольное приложение, dll, пакет, ActiveX (наверное, есть еще варианты). Выбор вида компиляции связан со спецификой задачи, требованиями пользователя и вкусами разработчика. К этому вопросу я еще раз вернусь в разделе Исполнение кода.
Настройка "быстрых" меню Maplnfo
MapInfo вызывает "быстрые" меню, если пользователь нажимает правую кнопку мышки в окне MapInfo. Эти меню появляются даже во внедренных приложениях. В зависимости от характера Вашего приложения Вы можете захотеть модифицировать или даже удалить такое меню. Например, Вы, возможно, захотите удалить команду ДУБЛИРОВАТЬ ОКНО, так как эта команда не работает в OLE-приложении.Чтобы удалить одну или несколько команд из локального меню, используйте оператор MapBasic Alter Menu... Remove или переопределите меню целиком, используя оператор Create Menu. Подробнее смотрите в Справочнике MapBasic.
Чтобы добавить команду к локальному меню, используйте оператор MapBasic Alter Menu ... Add и синтаксис предложений Calling OLE.
Чтобы удалить "быстрое" меню полностью, используйте оператор MapBasic Create Menu и управляющий код "(-" как новое определение меню. Например, следующий оператор разрушает "быстрое" меню для окон Карты: KDMapInfoServer1.ExecuteCommandMapBasic(' "Create Menu ""MapperShortcut"" ID 17 As ""(-"" " ', []);
Некоторые правила для работы с портами
Следует иметь в виду что при разработке программ имеющих дело работы с портами следует учитывать следующие факторы :Маленький пример для работы с портами (первый пример был уже опубликован в королевстве Дельфи и представлял собой пример работы с весами ПетрВес) function PortInit : boolean; //инициализация var f: THandle; ct: TCommTimeouts; dcb: TDCB; begin f := Windows.CreateFile(PChar('COM1'), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (f < 0) or not Windows.SetupComm(f, 2048, 2048)or not Windows.GetCommState(f, dcb) then exit; //init error dcb.BaudRate := скоpость; dcb.StopBits := стоп-биты; dcb.Parity := четность; dcb.ByteSize := 8; if not Windows.SetCommState(f, dcb) or not Windows.GetCommTimeouts(f, ct) then exit; //error ct.ReadTotalTimeoutConstant := 50; ct.ReadIntervalTimeout := 50; ct.ReadTotalTimeoutMultiplier := 1; ct.WriteTotalTimeoutMultiplier := 0; ct.WriteTotalTimeoutConstant := 10; if not Windows.SetCommTimeouts(f, ct) or not Windows.SetCommMask(f, EV_RING + EV_RXCHAR + EV_RXFLAG + EV_TXEMPTY) then exit; //error result := true; end; function DoneComm: boolean; //закpыть поpт begin result := Windows.CloseHandle(f); end; function PostComm(var Buf; size: word): integer; //пеpедача в поpт var p: pointer; i: integer; begin p := @Buf; result := 0; while size > 0 do begin if not WriteFile(f, p^, 1, i, nil) then exit; inc(result, i); inc(integer(p)); dec(size); Application.ProcessMessages; end; end; function ReadComm(var Buf; size: word): integer; //пpием из поpта var i: integer; ovr: TOverlapped; begin fillChar(buf, size, 0); fillChar(ovr, sizeOf(ovr), 0); i := 0; result := -1; if not windows.ReadFile(f, buf, size, i, @ovr) then exit; result := i; end; Данный пример был взят мной из многочисленный FAQ посвященных в DELPHI в сети ФИДО
Итак,для работы с портами COM и LPT нам понадобится знание функций Windows API.
Вот подробное описание функций, которые нам нужны (в эквиваленте C) для работы с портами.
(извините за возможный местами неточный перевод ,если что поправьте меня если что не так перевел)
| CreateFile |
HANDLE CreateFile( LPCTSTR lpFileName, // указатель на строку PCHAR с именем файла DWORD dwDesiredAccess, // режим доступа DWORD dwShareMode, // share mode LPSECURITY_ATTRIBUTES lpSecurityAttributes, // указатель на атрибуты DWORD dwCreationDistribution, // how to create DWORD dwFlagsAndAttributes, // атрибуты файла HANDLE hTemplateFile // хендл на temp файл ); Пример кода на Дельфи CommPort := 'COM2'; hCommFile := CreateFile(Pchar(CommPort), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Параметры LpFileNameУказатель на строку с нулевым символом в конце (PCHAR) , которая определяет название создаваемого объекта (файл, канал, почтовый слот, ресурс связи (в данном случае порты), дисковое устройство, приставка, или каталог) DwDesiredAccessУказывает тип доступа к объекту ,принимает значение
Чтобы разделять объект(цель), используйте комбинацию одних или большее количество следующих значений:
Возвращаемые значения
Если функция преуспевает, возвращаемое значение - открытый дескриптор к указанному объекту(файлу). Если файл не существует - 0.
Если произошли функциональные сбои, возвращаемое значение - INVALID_HANDLE_VALUE. Чтобы получить расширенные данные об ошибках, вызовите GetLastError.
Обратите внимание !
Для портов, dwCreationDistribution параметр должен быть OPEN_EXISTING, и hTemplate должен быть Nil. Доступ для чтения-записи должен быть определен явно.
| SECURITY_ATTRIBUTES |
Структура содержит описание защиты для объекта и определяет,может ли дескриптор быть унаследован дочерними процессами. typedef struct _SECURITY_ATTRIBUTES { DWORD nLength; LPVOID lpSecurityDescriptor; BOOL bInheritHandle; } SECURITY_ATTRIBUTES;
Параметры
NLengthОпределяет размер, в байтах, этой структуры. Набор это значение к размеру структуры SECURITY_ATTRIBUTES В Windows NT функции которые используют структуру SECURITY_ATTRIBUTES, не проверяют значение nLength. LpSecurityDescriptorДескриптор указывающий на описатель защиты для объекта, Если дескриптор ПУСТОЙ объект может быть назначен в наследование дочерними процессами. BInheritHandleОпределяет, унаследован ли возвращенный дескриптор, когда новый дескриптор, создан. Если это значение принимает ИСТИНУ новый дескриптор наследует от головного. Замечания
Указатель на структуру SECURITY_ATTRIBUTES используется как параметр в большинстве функций работы с окнами в Win32 API.
Продолжение следует...
, часть II
18 апреля 2001 г.
Специально для
Почему Perl ?
Благодаря возможности использования технологии поиска по шаблонам языка Perl становится возможной реализация техники "выборочного разбора" (selective parsing), то есть поиск и обнаружение интерпретируемых фрагментов текста, погружённых в тело сканируемого текста. Если сканируемым текстом является исходный код, то интерпретируемые фрагменты можно погружать в тело коментариев, и обрабатывать их на стадии препроцессирования.Положительным качеством языка Perl, как скриптового языка, является "лёгкость" и "быстрота" реализации и отладки прикладных систем на нём. Можно ожидать, что сложность этих систем, учитывая довольно высокую эффективность Perl, может быть достаточно высокой.
Немаловажным качеством Perl является его портабельность. В контексте данной статьи, учитывая появление Kylix, это качество становится одним из определяющих.
Требования к функциям уведомления
Программа должна быть способна функционировать, как DDE-сервер или как сервер Автоматизации OLE. Предопределенные процедуры SetStatusText, WindowContentsChanged.Возможно так-же и регистрация пользовательских событий. но это отложим пока на третью часть.
Получение контролов аудиолинии.
MMRESULT mixerGetLineControls( HMIXEROBJ hmxobj, LPMIXERLINECONTROLS pmxlc, DWORD fdwControls );Возвращает один или более контролов, ассоциированных с аудиолинией.
hmxobj -- обработчик микшера, которого мы опрашиваем.
pmxlc -- указатель на структуру MIXERLINECONTROLS.. Эта структура используется для ссылки на одну или более структур MIXERCONTROL, которые заполняются информацией о контролах. Поле cbStruct -- размер в байтах структуры MIXERLINECONTROLS должно быть заполнено.
fdwControls -- флаги, определяющие возвращаемую информацию. Мы задаем комибинацию MIXER_GETLINECONTROLSF_ALL or MIXER_OBJECTF_HMIXER. MIXER_GETLINECONTROLSF_ALL -- параметр pmxlc ссылается на список структур MIXERCONTROL, которые заполняются информацией обо всех контролах данной аудиолинии. В поле cControls должно быть записано число контролов, а взять его можно из cControls структуры MIXERLINE данной линии.
Поле сbmxctrl содержит размер одиночной структуры MIXERCONTROL и должно быть установлено. Поле pamxctrl должно содержать указатель на первую структуру MIXERCONTROL. Остальные флаги не рассматриваю, сделайте это самостоятельно.
MIXERLINECONTROLS
Структура с информацией о контролах аудиолинии.
typedef struct { DWORD cbStruct; DWORD dwLineID; union { DWORD dwControlID; DWORD dwControlType; }; DWORD cControls; DWORD cbmxctrl; LPMIXERCONTROL pamxctrl; } MIXERLINECONTROLS; cbStruct -- размер структуры в байтах.
dwLineID -- идентификатор линии, про которую мы спрашиваем. Берем его из MIXERLINE.
dwControlID -- работает с флагом MIXER_GETLINECONTROLSF_ONEBYID и нам пока неинтересен.
dwControlType -- работает с флагом MIXER_GETLINECONTROLSF_ONEBYTYPE и нам пока неинтересен.
cControls -- число элементов MIXERCONTROL в списке. Не может быть нулевым. Мы устанавливаем его из cControls структуры MIXERLINE.
cbmxctrl -- размер в байтах одиночной структуры MIXERCONTROL
pamxctrl -- указатель на первую структуру MIXERCONTROL в списке.
MIXERCONTROL
Структура с информацией об одиночном элементе управления аудиолинии.
typedef struct { DWORD cbStruct; DWORD dwControlID; DWORD dwControlType; DWORD fdwControl; DWORD cMultipleItems; CHAR szShortName[MIXER_SHORT_NAME_CHARS]; CHAR szName[MIXER_LONG_NAME_CHARS]; union { struct { LONG lMinimum; LONG lMaximum; }; struct { DWORD dwMinimum; DWORD dwMaximum; }; DWORD dwReserved[6]; } Bounds; union { DWORD cSteps; DWORD cbCustomData; DWORD dwReserved[6]; } Metrics; } MIXERCONTROL, *PMIXERCONTROL, FAR *LPMIXERCONTROL;
cbStruct -- размер структуры в байтах.
dwControlID -- идентификатор контрола, про который мы спрашиваем.
dwControlType -- тип контрола, про который мы спрашиваем.
Типов опять же много, но нам интересны пока два:
MIXERCONTROL_CONTROLTYPE_MUTE -- включение/выключение звука
MIXERCONTROL_CONTROLTYPE_VOLUME -- громкость звука
Остальные типы можно посмотреть сами знаете где.
fdwControl -- флаги статуса и поддерживаемых свойств. Их тоже хватает. Смотрите.
cMultipleItems -- число элементов для многоэлементных контролов. Нам пока неинтересен.
szShortName -- короткое имя контрола
szName -- полное именование контрола
Bounds -- граничные значения для параметра контрола. Полезно проверять.
Metrics -- граничные значения для метрик. Зачем это, без стакана не понять.
Уровень 4. Свойства элементов управления (control details). Структуры и функции, предназначенные для работы со свойствами контролов аудиолинии.
Все контролы подразделяются на несколько типов:
Нам интересны фейдеры и свитчи. Фейдер - обычный контрол с линейной вертикальной шкалой и ползунком, который перемещается вверх и вниз. Например, громкость именно таким контролом и регулируется. Для громкости шкала назначена от 0 и до 65535. Свитч - контрол, имеющий только два состояния. Например, чекбокс для MUTE. А больше и сказать особо нечего. Все остальное посмотреть можно сами знаете где :)
Cервер автоматизации OLE для обработки CallBack.
 | Данный сервер я разместил в ActiveX DLL.(данная DLL называется MICallBack.dll) в виде Automation Object.-а. Что-бы вам просмотреть методы и свойства данногоAutomation Object.-а. откройте MICallBack.dpr и в меню Run Delphi выбирите TypeLibrary |
| Откроется окно - Где я реализовал CallBack методы MapInfo и создал сервер автоматизации MICallBack. Обратите внимание, что у данного сервера помимо присутствия интерфейса IMapInfoCallBack присутствует и еще интерфейс ImapInfoCallBackEvents (он нам нужен будет для перенаправления событий в компонент и далее в обработчик). |  |
Листинг интерфейсного модуля
unit Call; {$WARN SYMBOL_PLATFORM OFF} interface uses ComObj, ActiveX, Dialogs, AxCtrls, Classes, MICallBack_TLB, StdVcl; type TMapInfoCallBack = class(TAutoObject, IConnectionPointContainer, IMapInfoCallBack) private { Private declarations } FConnectionPoints: TConnectionPoints; FConnectionPoint: TConnectionPoint; FEvents: IMapInfoCallBackEvents; { note: FEvents maintains a *single* event sink. For access to more than one event sink, use FConnectionPoint.SinkList, and iterate through the list of sinks. } public procedure Initialize; override; protected { Protected declarations } property ConnectionPoints: TConnectionPoints read FConnectionPoints implements IConnectionPointContainer; procedure EventSinkChanged(const EventSink: IUnknown); override; procedure SetStatusText(const Status: WideString); safecall; procedure WindowContentsChanged(ID: Integer); safecall; procedure MyEvent(const Info: WideString); safecall; end; var FDLLCall : THandle; implementation uses ComServ; procedure TMapInfoCallBack.EventSinkChanged(const EventSink: IUnknown); begin FEvents := EventSink as IMapInfoCallBackEvents; end; procedure TMapInfoCallBack.Initialize; begin inherited Initialize; FConnectionPoints := TConnectionPoints.Create(Self); if AutoFactory.EventTypeInfo <> nil then FConnectionPoint := FConnectionPoints.CreateConnectionPoint( AutoFactory.EventIID, ckSingle, EventConnect) else FConnectionPoint := nil; end; procedure TMapInfoCallBack.SetStatusText(const Status: WideString); begin IF FEvents <> nil Then begin FEvents.OnChangeStatusText(Status); end; end; procedure TMapInfoCallBack.WindowContentsChanged(ID: Integer); begin IF FEvents <> nil Then begin FEvents.OnChangeWindowContentsChanged(ID); end; end; procedure TMapInfoCallBack.MyEvent(const Info: WideString); begin IF FEvents <> nil Then begin FEvents.OnChangeMyEvent(Info); end; end; initialization TAutoObjectFactory.Create(ComServer, TMapInfoCallBack, Class_MapInfoCallBack, ciMultiInstance, tmApartment); end. Обратите внимание на присутствие двух предопределенных методов MapInfo SetStatusText и WindowContentsChanged.
Метод MyEvent я пока зарезервировал для реализации своих сообщений (более подробно будет изложено в 3 части цикла)
И так что мы видим. IF FEvents <> nil Then // если есть обработчик begin FEvents.OnChangeStatusText(Status); // Отправка сообщения далее - в данном случае в компонент
Концепции Интегрированной Картографии
Для создания приложения с Интегрированной Картой Вы должны написать программу - но не программу на языке MapBasic. Приложения с Интегрированной Картой могут быть написаны на нескольких языках программирования, среди которых наиболее часто используются С,Visual Basic,Delphi.В Вашей программе должна присутствовать инструкция, запускающая MapInfo в фоновом режиме. Например, в программе Вы можете запустить MapInfo вызовом функции CreateObject(). Программа MapInfo запускается в фоновом режиме незаметно для пользователя, не выводя заставку на дисплей. Ваша программа осуществляет управление программой MapInfo, конструируя строки, представляющие операторы языка MapBasic, которые затем передаются в MapInfo посредством механизмауправления объектами OLE (OLE Automation) или динамического обмена данных (DDE). MapInfo выполняет эти операторы точно так же, как если бы пользователь вводил их с клавиатуры в окно MapBasic.
Примечание:
Переподчинение окон MapInfo другому приложению не дает программе MapInfo автоматического доступа к данным этого приложения. Для отображения данных приложения в окне MapInfo Вы должны предварительно записать эти данные в таблицу MapInfo.
Особенности объектной модели Object Pascal
Особенностью объектной модели Object Pascal, сказывающейся на реализации описанным в статье методом шаблонов, является отсутствие операционной идентичности объектных типов языка базовым, то есть наличие отдельных правил создания, деструкции и присваивания значений переменных для объектных типов. Это свойство приводит к необходимости реализации отдельных шаблонов для объектных типов данных. Реализация их, впрочем возможна на основе шаблонов для базовых типов языка.Переинсталяция компонента TKDMapInfoServer.
| |  |
Теория.
Представлю несколько упрощённую архитектуру WMI в том виде, в котором она нас будет интересовать в нашем конкретном случае. Быстро пробежимся по всем её компонентам.
Объекты Win32 - с этим элементом ассоциированы компоненты Win32, к данным которых мы желаем получить доступ Провайдер Win32 - представители объектов Win32, т.е. провайдер осуществляет связь между "внешним миром" и компонентами системы. Нас провайдеры будут интересовать как COM (DCOM) серверы, которые могут быть реализованы как внутренние (в виде DLL), так и внешние (в виде самостоятельных приложений). CIM Object Manager - попросту говоря, это служба координации данных передаваемых в обоих направлениях (будь то запрос от управляющей программы к провайдеру или данные предоставляемые провайдером приложению). Классы CIM - вернее база данных, содержащая классы, которые есть не что иное, как шаблоны управляемых элементов, т.е. каждый класс описывает какой-то элемент и содержит свойства и методы для работы с этим элементом. Windows Management API - интерфейс прикладного программирования, по средствам которого управляющие приложения обращаются к объектам, а провайдеры поставляют данные и определения класса. Наша программа является в данном случае не чем иным как контроллером, работающим с помощью Windows Management API с провайдерами (серверами).
На этом я закончу теоретическое вступление и перейду к практической части.
Получение значений свойств контрола аудиолинии
MMRESULT mixerGetControlDetails( HMIXEROBJ hmxobj, LPMIXERCONTROLDETAILS pmxcd, DWORD fdwDetails );Возвращает харатеристики одиночного контрола аудиолинии.
hmxobj -- обработчик микшера, которого мы опрашиваем.
pmxcd -- указатель на структуру MIXERCONTROLDETAILS, которая заполняется информацией о контроле.
fdwDetails -- флаги, определяющие возвращаемую информацию. Используем MIXER_GETCONTROLDETAILSF_VALUE or MIXER_OBJECTF_HMIXER.
MIXER_GETCONTROLDETAILSF_VALUE -- возвращается текущее значение контрола. PaDetails структуры MIXERCONTROLDETAILS указывает на структуры с детальной информацией по контролу.
Установка значений свойств контрола аудиолинии
MMRESULT mixerSetControlDetails( HMIXEROBJ hmxobj, LPMIXERCONTROLDETAILS pmxcd, DWORD fdwDetails );Устанавливает харатеристики одиночного контрола аудиолинии.
hmxobj -- обработчик микшера, которого мы опрашиваем.
pmxcd -- указатель на структуру MIXERCONTROLDETAILS, которая заполнена информацией о контроле предыдущим вызовом mixerGetControlDetails.
fdwDetails -- флаги, определяющие возвращаемую информацию. Используем MIXER_OBJECTF_HMIXER or MIXER_SETCONTROLDETAILSF_VALUE.
MIXER_SETCONTROLDETAILSF_VALUE -- устанавливается новое значение контрола.
PaDetails из структуры MIXERCONTROLDETAILS указывает на структуру, соответствующую типу контрола.
При вызове этих функций используется структура
MIXERCONTROLDETAILS
Эта структура указывает на список структур, содержащих конкретную информацию по контролам аудиолинии.
typedef struct { DWORD cbStruct; DWORD dwControlID; DWORD cChannels; union { HWND hwndOwner; DWORD cMultipleItems; }; DWORD cbDetails; LPVOID paDetails; } MIXERCONTROLDETAILS;
cbStruct -- размер структуры в байтах.
dwControlID -- идентификатор контрола, свойства которого мы читаем/изменяем
cChannels - число каналов, свойства которых меняются. Ставьте значение 0, 1 или MIXERLINE.cChannels, если свойства контрола относятся ко всем каналам аудиолинии. Других значений не ставьте.
hwndOwner - указатель окна. Для наших целей неважно. Ставьте 0.
cMultipleItems - ставьте 0 и будет хорошо
cbDetails - размер структуры, содержащей конкретную информацию по контролу.
paDetails - указатель на одну или более структур, содержащих конкретную информацию по контролу.
Из структур, содержащих конкретную информацию по контролам аудиолинии, сейчас нас интересуют только две, связанные с управлением громкостью и включением звука: MIXERCONTROLDETAILS_BOOLEAN и MIXERCONTROLDETAILS_UNSIGNED.
MIXERCONTROLDETAILS_BOOLEAN
Возвращает или устанавливает значение свойства контрола булевского типа.
typedef struct { LONG fValue; } MIXERCONTROLDETAILS_BOOLEAN;
fValue - значение логического типа ( 0- FALSE, ненулевое - TRUE)
Подходит для управления контролом типа MIXERCONTROL_CONTROLTYPE_MUTE.
MIXERCONTROLDETAILS_UNSIGNED
Возвращает или устанавливает значение свойства контрола целого беззнакового типа.
typedef struct { DWORD dwValue; } MIXERCONTROLDETAILS_UNSIGNED;
dwValue - Целое беззнаковое
Подходит для управления контролом типа MIXERCONTROL_CONTROLTYPE_VOLUME
Без уровня. Поддержка сообщений. Отправка определенного пользователем сообщения.
DWORD mixerMessage( HMIXER hmx, UINT uMsg, DWORD_PTR dwParam1, DWORD_PTR dwParam2 );
Посылка пользовательского сообщения напрямую драйверу микшера
hmx -- обработчик открытого микшера
uMsg -- пользовательское сообщение Должно быть больше или равно MXDM_USER.
dwParam1, dwParam2 -- параметры сообщения.
MM_MIXM_CONTROL_CHANGE
Сообщение, которое посылается микшером приложению чтобы уведомить об изменении состояния контрола.
wParam = (WPARAM) hMixer
lParam = (LPARAM) dwControlID
hMixer -- обработчик микшера, который послал сообщение.
dwControlID -- идентификатор контрола, который изменил состояние.
MM_MIXM_LINE_CHANGE
Сообщение, которое посылается микшером приложению чтобы уведомить об изменении состояния аудиолинии.
wParam = (WPARAM) hMixer
lParam = (LPARAM) dwLineID
hMixer -- обработчик микшера, который послал сообщение.
dwLineID -- идентификатор аудиолинии, которая изменила свое состояние.
И еще немножко :)
Вот, собственно, и все, что желательно знать, чтобы начать работать с микшером. Да и этого многовато ;) В качестве примера приведена программа, которая прочитывает все, что связано с микшером и отображает это в виде дерева
Далее по плану: как записать звук и что такое fullduplex.
Исполнение кода
Как я уже говорил, возможны различные варианты того, в какой вид будет скомпилирована задача, сформулированная технологом. Если технолог передает результаты своей работы конечному пользователю, то удобный вариант - exe-файл. Если технолог решает некоторую задачу и сразу же пользуется результатами решения, то сам факт компиляции должен быть для него полностью прозрачен (или максимально незаметен). Технолог работает в программе, которая сделана разработчиком и, по большому счету, ему совершенно безразлично, каким конкретно способом разработчик предоставляет возможность изменять функциональность программы. Существует несколько технологий построения гибко подгружаемых модулей, и они описаны в литературе. Я остановлюсь только на одной технологии - динамическая загрузка и выгрузка DLL. Если результирующий проект, который нужен технологу, содержит визуальные формы (а их можно генерировать как dfm-файлы), то вероятно, более предпочтительными будут пакеты.Возможен также вариант, когда исполняемый код делится на две составляющие - исполняемое ядро (exe-файл) и подгружаемый модуль. Ядро создается разработчиком и динамически подключает модули, создаваемые технологом. Достоинство такого подхода в том, что работу с визуальными компонентами можно сосредоточить в ядре, а в DLL формировать только алгоритмическую часть задачи. Другое достоинство такого подхода - технолог может работать в мощной интегрированной среде, а конечному пользователю он передает только ядро и нужный модуль, скрывая от пользователя все технологические детали.
Для работы с DLL, в библиотеку DccUsing добавлен класс TDllWrap - простая оболочка, инкапсулирующая дескриптор загруженной DLL. Основные методы класса:
public constructor Create(const aDllPath: String); destructor Destroy; override; function Execute(const aFunctionName: String; const aInterface: Pointer): Pointer;
Конструктор Create просто сохраняет путь к файлу DLL и больше ничего не делает, деструктор Destroy выгружает DLL из памяти, если она была загружена. Основную работу делает метод Execute - он вызывает экспортируемую функцию DLL по имени и передает ей указатель на интерфейс вызывающей части. Экспортируемая функция возвращает интерфейс вызываемой части. Более подробно о взаимодействии вызывающей и вызываемой частей поговорим в следующем разделе, а пока рассмотрим реализацию метода Execute.
function TDllWrap.Execute( const aFunctionName: String; const aInterface: Pointer): Pointer; var f: TDllFunction; begin if FDllInst = 0 then begin if not FileExists(FDllPath) then raise Exception.Create(SFileNotFound + FDllPath); FDllInst := LoadLibrary(PChar(FDllPath)); if FDllInst = 0 then raise Exception.Create(SCantLoadDll + SysErrorMessage(GetLastError)); end; f := TDllFunction(GetProcAddress(FDllInst, PChar(aFunctionName))); if not Assigned(f) then raise Exception.Create(SCantFindFunction + aFunctionName); result := f(aInterface); end;
Вначале метод Execute контролирует - загружена ли DLL? и, если DLL еще не загружена, то она загружается. Если загрузка была успешной, то с помощью функции GetProcAddress получаем адрес экспортируемой функции по ее символическому имени (можно также использовать индекс). Если адрес функции успешно получен, то вызываем ее и передаем ей аргумент - указатель на вызывающий интерфейс. Функция возвращает указатель на вызываемый интерфейс. Из этой реализации видно, что вызывающая часть может обратиться с помощью метода Execute к нескольким различным функциям DLL или многократно к одной и той же функции - DLL будет загружена только один раз.
Как заставить MapInfo пересылать
Итак представляю переработанный компонент - unit KDMapInfoServer; interface uses Stdctrls,Dialogs,ComObj,Controls,Variants,ExtCtrls,Windows,ActiveX, Messages,SysUtils,Classes,MICallBack_TLB; // - сгенерировано из DLL Type // запись "типа" Variant TEvalResult = record AsVariant: OLEVariant; AsString: String; AsInteger: Integer; AsFloat: Extended; AsBoolean: Boolean; end; type // Событие на изменение SetStatusText // генерируется при обратном вызове TSetStatusTextEvent = procedure(Sender : TObject; StatusText: WideString) of object; // WindowContentsChanged TWindowContentsChanged = procedure(Sender : TObject; ID : Integer) of object; // Для собственных событий TMyEvent = procedure(Sender : TObject; Info : WideString) of object; TEvent = class(TInterfacedObject,IUnknown,IDispatch) private FAppConnection : Integer; FAppDispatch : IDispatch; FAppDispIntfIID : TGUID; protected function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; public Constructor Create( AnAppDispatch : IDispatch; Const AnAppDispIntfIID : TGUID); Destructor Destroy ; override; end; TKDMapInfoServer = class(TComponent) private FOwner : TWinControl; // Владелец Responder : Variant; // Для OLE Disp FServer : Variant; FHandle : THandle; // Зарезервировано FActive : Boolean; // Запущен/ незапущен FPanel : TPanel; // Панель вывода srv_OLE : OLEVariant; srv_disp : IMapInfoCallBackDisp; srv_vTable : IMapInfoCallBack; FEvent : TEvent; FSetStatusTextEvent : TSetStatusTextEvent; // события компонента FWindowContentsChanged : TWindowContentsChanged; FMyEvent : TMyEvent; Connected : Boolean; // Установлено ли соединение MapperID : Cardinal; // ИД окна procedure SetActive(const Value: Boolean); procedure SetPanel(const Value: TPanel); procedure CreateMapInfoServer; procedure DestroyMapInfoServer; { Private declarations } protected { Protected declarations } public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; // Данная процедура выполеняет метод сервера MapInfo - Do procedure ExecuteCommandMapBasic(Command: String; const Args: array of const); function Eval(Command: String; const Args: array of const): TEvalResult; virtual; procedure WindowMapDef; procedure OpenMap(Path : String); procedure RepaintWindowMap; // Дополнил для генерации события SetStatus при изменении строки состояния // в MapInfo procedure DoSetStatus(StatusText: WideString); // Дополнил.для генерации события WindowContentsChanged при изменении окна // в MapInfo procedure DoWindowContentsChanged(ID : Integer); // Дополнил для генерации собственно события в MapInfo procedure DoMyEvent(Info: WideString); published { Published declarations } // Создает соединение с сервером MapInfo property Active: Boolean read FActive write SetActive; property PanelMap : TPanel read FPanel write SetPanel; // Событие возникающее при изменении строки состояния MapInfo property StatusTextChange : TSetStatusTextEvent read FSetStatusTextEvent write FSetStatusTextEvent; Property WindowContentsChanged : TWindowContentsChanged read FWindowContentsChanged write FWindowContentsChanged; Property MyEventChange : TMyEvent read FMyEvent write FMyEvent; end; var // О это вообще хитрость - используеться для определения созданного компонента // TKDMapInfoServer (см. SetStatusText и Create KDMapInfoServ : TKDMapInfoServer; procedure Register; implementation // Вот тут то и хитрость если сервер создан то тогда и вызываем SetStatus //// IF KDMapInfoServ <> nil Then /// KDMapInfoServ.SetStatus(StatusText); procedure Register; begin RegisterComponents('Kuzan', [TKDMapInfoServer]); end; { TKDMapInfoServer } constructor TKDMapInfoServer.Create(AOwner: TComponent); begin inherited Create(AOwner); FOwner := AOwner as TWinControl; KDMapInfoServ := Self; // **** Вот тут и указываеться созданный компонент // TKDMapInfoServer FHandle := 0; FActive := False; Connected := False; end; destructor TKDMapInfoServer.Destroy; begin DestroyMapInfoServer; inherited Destroy; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.CreateMapInfoServer; begin try FServer := CreateOleObject('MapInfo.Application'); except FServer := Unassigned; end; // Скрываем панели управления MapInfo ExecuteCommandMapBasic('Alter ButtonPad ID 4 ToolbarPosition (0, 0) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 3 ToolbarPosition (0, 2) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 1 ToolbarPosition (1, 0) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 2 ToolbarPosition (1, 1) Show Fixed', []); ExecuteCommandMapBasic('Close All', []); ExecuteCommandMapBasic('Set ProgressBars Off', []); ExecuteCommandMapBasic('Set Application Window %D', [FOwner.Handle]); ExecuteCommandMapBasic('Set Window Info Parent %D', [FOwner.Handle]); FServer.Application.Visible := True; if IsIconic(FOwner.Handle)then ShowWindow(FOwner.Handle, SW_Restore); BringWindowToTop(FOwner.Handle); srv_ole := CreateOleObject('MICallBack.MapInfoCallBack') as IDispatch; srv_vtable := CoMapInfoCallBack.Create; srv_disp := CreateComObject(CLASS_MapInfoCallBack) as IMapInfoCallBackDisp; FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents); // Указываем MapInfo что нужно передовать обратные вызовы нашему OLE // а тм далее по цепочке (см.начало) FServer.SetCallBack(srv_disp); end; procedure TKDMapInfoServer.DestroyMapInfoServer; begin ExecuteCommandMapBasic('End MapInfo', []); FServer := Unassigned; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.ExecuteCommandMapBasic(Command: String; const Args: array of const); begin if Connected then try FServer.Do(Format(Command, Args)); except on E: Exception do MessageBox(FOwner.Handle, PChar(Format('Ошибка выполнения () - %S', [E.Message])), 'Warning', MB_ICONINFORMATION OR MB_OK); end; end; //------------------------------------------------------------------------------ function TKDMapInfoServer.Eval(Command: String; const Args: array of const): TEvalResult; Function IsInt(Str : String): Boolean; var Pos : Integer; begin Result := True; For Pos := 1 To Length(Trim(Str)) do begin IF (Str[Pos] <> '0') and (Str[Pos] <> '1') and (Str[Pos] <> '2') and (Str[Pos] <> '3') and (Str[Pos] <> '4') and (Str[Pos] <> '5') and (Str[Pos] <> '6') and (Str[Pos] <> '7') and (Str[Pos] <> '8') and (Str[Pos] <> '9') and (Str[Pos] <> '.') Then Begin Result := False; Exit; end; end; end; var ds_save: Char; begin if Connected then begin Result.AsVariant := FServer.Eval(Format(Command, Args)); Result.AsString := Result.AsVariant; Result.AsBoolean := (Result.AsString = 'T') OR (Result.AsString = 't'); IF IsInt(Result.AsVariant) Then Begin try ds_save := DecimalSeparator; try DecimalSeparator := '.'; Result.AsFloat := StrToFloat(Result.AsString); finally DecimalSeparator := ds_save; end; except Result.AsFloat := 0.00; end; try Result.AsInteger := Trunc(Result.AsFloat); except Result.AsInteger := 0; end; end else Begin Result.AsInteger := 0; Result.AsFloat := 0.00; end; end; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.SetActive(const Value: Boolean); begin FActive := Value; IF FActive then begin CreateMapInfoServer; WindowMapDef; Connected := True; end else begin IF Connected then begin DestroyMapInfoServer; Connected := False; end; end; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.SetPanel(const Value: TPanel); begin FPanel := Value; end; procedure TKDMapInfoServer.WindowMapDef; begin ExecuteCommandMapBasic('Set Next Document Parent %D Style 1', [FPanel.Handle]); RepaintWindowMap; end; procedure TKDMapInfoServer.OpenMap(Path: String); begin ExecuteCommandMapBasic('Run Application "%S"', [Path]); MapperID := Eval('WindowInfo(FrontWindow(),%D)',[12]).AsInteger; RepaintWindowMap; end; procedure TKDMapInfoServer.DoSetStatus(StatusText: WideString); begin IF Assigned(FSetStatusTextEvent) then FSetStatusTextEvent(Self,StatusText); end; procedure TKDMapInfoServer.DoWindowContentsChanged(ID: Integer); begin IF Assigned(FWindowContentsChanged) then FWindowContentsChanged(Self,ID); end; procedure TKDMapInfoServer.DoMyEvent(Info: WideString); begin IF Assigned(FWindowContentsChanged) then FMyEvent(Self,Info); end; procedure TKDMapInfoServer.RepaintWindowMap; begin with PanelMap do MoveWindow(MapperID, 0, 0, FPanel.ClientWidth, FPanel.ClientHeight, True); end; { TEvent } function TEvent._AddRef: Integer; begin Result := 2; // Заглушка end; function TEvent._Release: Integer; begin Result := 1; // Заглушка end; constructor TEvent.Create(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin Inherited Create; FAppDispatch := AnAppDispatch; FAppDispIntfIID := AnAppDispIntfIID; // Передадим серверу InterfaceConnect(FAppDispatch,FAppDispIntfIID,self,FAppConnection); end; destructor TEvent.Destroy; begin InterfaceDisConnect(FAppDispatch,FAppDispIntfIID,FAppConnection); inherited; end; function TEvent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin // Заглушка не реализовано Result := E_NOTIMPL; end; function TEvent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin // Заглушка не реализовано Result := E_NOTIMPL; end; function TEvent.GetTypeInfoCount(out Count: Integer): HResult; begin // Заглушка не реализовано Count := 0; Result := S_OK; end; function TEvent.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; var Info,Status : String; IDWin : Integer; begin Case DispID of 1 : begin Status := TDispParams(Params).rgvarg^[0].bstrval; IF KDMapInfoServ <> nil Then KDMapInfoServ.DoSetStatus(Status); end; 2 : begin IDWin := TDispParams(Params).rgvarg^[0].bval; IF KDMapInfoServ <> nil Then KDMapInfoServ.DoWindowContentsChanged(IDWin); end; 3 : begin Info := TDispParams(Params).rgvarg^[0].bstrval; IF KDMapInfoServ <> nil Then KDMapInfoServ.DoMyEvent(Info); end; end; Result := S_OK; end; function TEvent.QueryInterface(const IID: TGUID; out Obj): HResult; begin Result := E_NOINTERFACE; IF GetInterface(IID,Obj) Then Result := S_OK; If IsEqualGUID(IID,FAppDispIntfIID) and GetInterface(IDispatch,Obj) Then Result := S_OK; end; end. И так что добавилось - Метод CreateMapInfoServer; // Создаем наш сервер OLE srv_ole := CreateOleObject('MICallBack.MapInfoCallBack') as IDispatch; srv_vtable := CoMapInfoCallBack.Create; // Получаем Idispatch созданного сервера srv_disp := CreateComObject(CLASS_MapInfoCallBack) as IMapInfoCallBackDisp; FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents); // Указываем MapInfo что нужно передовать обратные вызовы нашему OLE серверу // а там далее по цепочке (см.начало) FServer.SetCallBack(srv_disp); end; Здесь мы столкнулись с еще одним методом MapInfo помимо рассмотренных ранее методов Do и Eval- Метод SetCallBack(IDispatch) Описание -Регистрирует объект механизма-управления объектами OLE (OLE Automation) как получатель уведомлений, генерируемых программой MapInfo. Только одна функция уведомления может быть зарегистрирована в каждый данный момент. Параметр интерфейс Idispatch объекта OLE (COM)
Реализация FServer.SetCallBack(srv_disp); - данным кодом мы заставили MapInfo уведомлять наш OLE сервер.
Хорошо, скажете вы, ну заставили но он то уведомляет сервер OLE а не нашу программу, для этого я ввел следующий код (прим. Реализацию использования интерфейса событий OLE сервера я подробно расписывать не стану - для этого читайте в книгах главы по COM)
Я сделал так: ввел класс отвечающий за принятие событий от COM(OLE) объекта TEvent = class(TInterfacedObject,IUnknown,IDispatch) private FAppConnection : Integer; FAppDispatch : IDispatch; FAppDispIntfIID : TGUID; protected function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; public Constructor Create( AnAppDispatch : IDispatch; Const AnAppDispIntfIID : TGUID); Destructor Destroy ; override; end; создание этого класса в компоненте реализовано так FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents); В методе Invoke и происходит прием и получение сообщений и пересылка их в обработчик моего компонента.
Еще раз на последующие вопросы касательно COM (OLE) серверов отвечу: данная тема выходит за рамки данной статьи - советую почитать книгу Александроского А.Д - Delphi 5 разработка корпоративных приложений.
Напоследок — модуль MICallBack_TLB.pas импортирован из DLL командой меню DELPHI Import Type Libray.
Примечание:
при импорте данный сервер инсталировать не нужно, нет смысла он нам нужен только для приема сообщений из MapInfo.
Вот в принципе все во второй части; создание пользовательских событий и обработка их в следующей главе.
До встречи
Скачать компонент (540 К)
2002 год.
Специально для
Обработка переданных данных
Когда пользователь использует команды или кнопки, MapInfo посылает Вашему OLE-методу строку, содержащую восемь элементов, разделенных запятыми. Например, строка, посланная MapInfo, может выглядеть так: "MI:-73.5548,42.122,F,F,-72.867702,43.025,202," Содержание такой строки проще понять, если Вы уже знакомы с функцией MapBasic CommandInfo(). Когда Вы пишете приложения, Вы можете создать новые команды меню и кнопки, вызывающие MapBasic-процедуры. Внутри процедуры-обработчика вызовите функцию CommandInfo(), чтобы получить информацию. Например, следующее обращение к функции определяет, координату Х и У места на карте где пользователи применил инструмент. var X,Y : String; begin KDMapInfoServer1.ExecuteCommandMapBasic('Set CoordSys Layout Units "mm"',[]); X := KDMapInfoServer1.Eval('CommandInfo(%S)',[CMD_INFO_X]).AsString; Y := KDMapInfoServer1.Eval('CommandInfo(%S)',[ CMD_INFO_Y]).AsString; ShowMessage('X= ' + X + ' Y = ' + Y);| Значение | Код для событий, связанных с меню | Код для событий, связанных с кнопкой |
| 1 | CMD_INFO_X | |
| 2 | CMD_INFO_Y | |
| 3 | CMD_INFO_SHIFT | |
| 4 | CMD_INFO_CTRL | |
| 5 | CMD_INFO_X2 | |
| 6 | CMD_INFO_Y2 | |
| 7 | CMD_INFO_TOOLBTN | |
| 8 | CMD_INFO_MENUITEM |
Когда Вы создаете команду меню или кнопку, которая использует синтаксис вызова OLE, MapInfo создает строку, содержащую разделенные запятой все восемь возвращаемых CommandInfo() значений. Строка начинается с префикса "MI:", чтобы Ваш OLE-сервер мог определять, что обращение метода было сделано MapInfo.
Строка, которую MapInfo посылает Вашему методу, выглядит следующим образом: "MI:" + CommandInfo(l) + "," + CommandInfo (2) + "," + CommandInfo(3) + "," + CommandInfo (4) + "," + CommandInfo(5) + "," + CommandInfo (6) + "," + CommandInfo (7) + "," + CommandInfo (8) Предположим, что Ваше приложение добавляет команду меню к локальному меню OLE-методу строку. Если команда меню имеет номер 101 , строка будут выглядеть следующим образом: "Ml :,,,,,,, 101" В этом случае большинство элементов строки пусто, потому что функция CommandInfo( ) может возвращать только эту одну часть информации.
Теперь предположим что вы создаете кнопку которая позволяет пользователю выбирать линии на карте.Строка теперь примет вид - "MI:-73.5548,42.122,F,F,-72.867702,43.025,202," Теперь строка включает несколько элементов.
Первые два элемента содержат х- и у координаты точки на которые пользователь указал мышкой
Следующие два элемента сообщают, была ли нажата клавиша SHIFT или CTRL
Предпоследнии два элемента содержат координаты точки где пользователь отпустил кнопку мышки.
И последний - указывает номер идентификатора кнопки.
Совет:
Если Вы приписываете уникальный идентификатор каждой из Ваших кнопок, Вы можете сделать так, что все кнопки будут вызывать один и тот же метод. Ваш метод может определять, какая из кнопка вызвала его, используя седьмой аргумент в переданной строке.
| use File::Basename; my %params; sub tem_process { my $fin = shift; my $fout = shift; while () { chomp($l = $_); foreach (keys(%params)) { my $ppp = qr/\/; my $val = $params{$_}; $l =~ s/$ppp/$val/g; } print $fout $l,"\n"; } } sub tem { $temname = shift; $outname = shift; $params = shift; if ($temname) { open FIN,$temname die "can't open TEM\n"; } else { FIN = STDIN; } if ($outname) { open FOUT,'>',$outname die "can't open tem OUT\n"; } else { FOUT = STDOUT; } %params = eval '('.$params.')'; $params{"ModName"} = basename($outname,".pas",".PAS"); # а кроме pas ? tem_process(FIN,FOUT); close(FIN) if ($temname); close(FOUT) if ($outname); } 1; __END__ |
Просмотр исходных файлов и выполнение запросов на инстанциацию (генерацию экземляра исходного модуля по шаблону) осуществляется скриптом temss.pl (ss - это сокращение от "scan sources" - сканирование исходных). Пояснений здесь требует, пожалуй только шаблон поиска запросов: "/!TEM!(\s|\n)*(\S+)(\s|\n)*(\S+)(\s|\n)*((.|\n)*?)(\s|\n)*!MET!/" Он соответствует текстовым последовательностям, заключенным между "!TEM!" и "!MET!" (расположенных на отдельных строках), состоящим из двух строк с ненулевыми непробельными последовательностями, и любого количества строк с последовательностями любых символов. Значимые строки запроса могут перемежаться любым количеством пустых строк. Текстовой файл загружается в память целиком (обычная практика в Perl, он это умеет делать очень быстро) и по нему осуществляется глобальный поиск с приведённым выше шаблоном с последующим выполнением обнаруженных запросов. Ниже приведён текст скрипта:
| temss. pl require Tem; sub ss { $src = shift; open FH,$src; my $l = join('',); close(FH); while ($l =~ /!TEM!(\s|\n)*(\S+)(\s|\n)*(\S+)(\s|\n)*((.|\n)*?)(\s|\n)*!MET!/g) { my $temname = $2; my $modname = $4; my $params = $6; print "generate $modname by $temname with\n>>\n"; tem($temname,$modname,$params); } } while () { ss($_); } |
Скрипт запускается в директории с исходными модулями, использующими шаблоны. Он сканирует все файлы с расширениями ".pas" и ".dpr" и генерирует тексты исходных модулей по запросам. Если наличествует более одного уровня вложения шаблонов (т.е. одни шаблоны используют другие), то скрипт должен быть запущен соответствующее (количеству уровней вложения) количество раз.
Шаблоны оформляются в виде файлов с расширением ".tem". На текстовое содержание шаблона никаких ограничений не накладывается. Текст шаблона может содержать в себе последовательности вида "", где "ИМЯ_ПАРАМЕТРА" заменяется именем конкретного параметра шаблона (например "
| MinMax.tem unit |
Запрос на инстанциацию шаблона оформляется в тексте исходного модуля, использующего шаблон следующим образом: ... {!TEM! ИМЯ_ФАЙЛА_ШАБЛОНА ИМЯ_ГЕНЕРИРУЕМОГО_МОДУЛЯ ИМЯ_ПАРАМЕТРА1=>ЗНАЧЕНИЕ_ПАРАМЕТРА1, ИМЯ_ПАРАМЕТРА2=>ЗНАЧЕНИЕ_ПАРАМЕТРА2, ... !MET!} ... Имеется один дополнительный параметр - ModName (имя модуля), значение которого определяется именем генерируемого модуля (с отбрасыванием расширения). Приведённый выше шаблон может быть использован следующим образом: ... {!TEM! MinMax.tem MinMaxInt.pas Type=>Integer !MET!} ... В результате выполнения такого запроса получим приведённый ниже модуль:
| MinMaxInt. pas unit MinMaxInt; interface function MinInteger(X,Y: Integer): Integer; function MaxInteger(X,Y: Integer): Integer; implementation function MinInteger; begin if X < Y then Result := X else Result := Y; end; function MaxInteger; begin if X > Y then Result := X else Result := Y; end; end. |
Важная особенность параметризации шаблонов: при инстанциации заменяются значениями вхождения только тех параметров, которые были указаны в запросе ! Эта свойство делает возможной использование техники каскадной генерации шаблонов - то есть генерацию шаблонов по шаблонам с последовательным уточнением параметров. Эта техника на практике пока не опробована.
Получение данных о центральном процессоре.
Этот первый пример я старался сделать как можно нагляднее и разберу я его достаточно подробно. В остальных же 3-х примерах я не буду повторяться в комментариях, а постараюсь продемонстрировать некоторые приёмы, которые, возможно, помогут вам в дальнейшем в ваших собственных программах.Создаём новый проект и добавляем к нему компоненту TSWbemLocator, которая должна появиться в палитре компонент после импортирования указанных выше библиотек типов. Далее я буду давать комментарии непосредственно в коде программы.
| unit Unit1; interface uses …, WbemScripting_TLB, OleServer, ActiveX; type TForm1 = class(TForm) … SWbemLocator1: TSWbemLocator; …; private { Private declarations } procedure ShowProp(SProp: SWBemProperty); public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); var Service: ISWbemServices; ObjectSet: ISWbemObjectSet; SObject: ISWbemObject; PropSet: ISWbemPropertySet; SProp: ISWbemProperty; PropEnum, Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; StrValue: string; begin // Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, nil); // SObject:= Service.Get('Win32_Processor', wbemFlagUseAmendedQualifiers, nil); // ObjectSet:= SObject.Instances_(0, nil); { Далее нам нужно из коллекции ObjectSet получить экземпляр объекта, соответствующий классу Win32_Processor. Делается это с помощью метода Item объекта ObjectSet. В качестве первого параметра этого метода указывается путь к объекту, экземпляр которого вы желаете извлечь из коллекции. Данный метод возвращает объект типа SWbemObject. Но нам не известно, как выглядит этот путь. Использовать дополнительный класс SwbemObjectPath тоже нет никакого желания. Так что делаю "финт ушами": } // SObject:= ObjectSet.Item('???', 0); Enum:= (ObjectSet._NewEnum) as IEnumVariant; Enum.Next(1, TempObj, Value); SObject:= IUnknown(TempObj) as SWBemObject; { Полагаю, что данный приём понятен читателю и в комментариях не нуждается. Вот практически и всё - осталось прочитать интересующие нас свойства. Сколько было слов и как всё просто оказалось в действительности :) Перебираем свойства объекта SObject: } while (PropEnum.Next(1, TempObj, Value) = S_OK) do begin SProp:= IUnknown(TempObj) as SWBemProperty; StrValue:= ''; ListBox1.AddItem(SProp.Name, nil); ShowProp(SProp); end; end; procedure TForm1.ShowProp(SProp: SWBemProperty); begin if (SProp.Get_Value <> null) then begin with SProp do begin if Name = 'Name' then Label2.Caption:= Get_Value else if Name = 'Manufacturer' then …. end; { with } end; { if } end; end. |
Пояснения к коду: Примечание 1 Подсоединяемся к пространству имён 'root\CIMV2' нашего компьютера. Метод ConnectServer принимает следующие параметры: objwbemServices = ConnectServer( [ strServer = "" ], [ strNameSpace = "" ], [ strUser = "" ], [ strPassword = "" ], [ strLocale = "" ], [ strAuthority = "" ], [ iSecurityFlags = 0 ], [ objwbemNamedValueSet = null ] )
Примечание 2 Теперь получим описание интересующего нас класса, т.е. Win32_Processor.
Делается это с помощью метода Get полученного нами объекта Service.
Метод Get принимает следующие параметры: objWbemObject = Get( [ strObjectPath = "" ], [ iFlags = 0 ], [ objWbemNamedValueSet = null ] )
Примечание 3 Теперь надо получить коллекцию экземпляров класса Win32_Processor.
Делается это с помощью метода Instances_ объекта SObject.
Метод Instances_ принимает следующие параметры: objWbemObjectSet = Instances_( [ iFlags = wbemFlagReturnImmediately ], [ objwbemNamedValueSet = null ] )
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\GetProcessorData и \Exe-files соответственно.
Вот что у меня получилось:
| … var Form1: TForm1; ListItem: TListItem; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); var Service: ISWbemServices; ObjectSet: ISWbemObjectSet; SObject: ISWbemObject; PropSet: ISWbemPropertySet; SProp: ISWbemProperty; PropEnum, Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; Column: TListColumn; begin ListView1.Items.BeginUpdate; ListView1.Items.Clear; Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0, nil); SObject:= Service.Get('Win32_Process', wbemFlagUseAmendedQualifiers, nil); ObjectSet:= SObject.Instances_(0, nil); Enum:= (ObjectSet._NewEnum) as IEnumVariant; { На данном этапе начинаются некоторые незначительные отличия от первого примера. В предыдущем примере, мы знали, что у нас был единственный экземпляр класса Win32_Processor, характеризующий центральный процессор. В данном примере мы имеем столько экземпляров, сколько запущенных процессов, поэтому их все необходимо перебрать и получить их свойства: } // в этом цикле перебираю все имеющиеся экземпляры while (Enum.Next(1, TempObj, Value) = S_OK) do begin SObject:= IUnknown(TempObj) as SWBemObject; PropSet:= SObject.Properties_; PropEnum:= (PropSet._NewEnum) as IEnumVariant; ListItem:= ListView1.Items.Add; // перебираю свойства while (PropEnum.Next(1, TempObj, Value) = S_OK) do begin SProp:= IUnknown(TempObj) as SWBemProperty; if ListView1.Items.Count = 1 then begin Column := ListView1.Columns.Add; Column.Width := 100; Column.Caption := SProp.Name; end; ShowProp(SProp); end; end; { while } ListView1.Items.EndUpdate; end; // В процедуре ShowProp происходит определение типа свойства // и соответствующие приведение типа. procedure TForm1.ShowProp(SProp: ISWbemProperty); var StrValue: string; Count: Cardinal; begin StrValue:= ''; if VarIsNull(SProp.Get_Value) then StrValue:= ' |
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ GetProcessData и \Exe-files соответственно.
А выглядит это так:
| … var Form1: TForm1; Service: ISWbemServices; InParam, OutParam, SObject, Process: ISWbemObject; Method: ISWbemMethod; SProp1, SProp2, MyProperty: ISWbemProperty; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); var PropValue: OleVariant; begin Service:= SWbemLocator1.ConnectServer('.', 'root\cimv2', '', '', '', '', 0, nil); // Service.Security_.Set_ImpersonationLevel(wbemImpersonationLevelImpersonate); Process:= Service.Get('Win32_Process', 0, nil); // Method:= Process.Methods_.Item('Create', 0); // InParam:= Method.InParameters.SpawnInstance_(0); // MyProperty:= InParam.Properties_.Add('CommandLine', wbemCimtypeString, False, 0); { С помощью метода Set_Value объекта ISWbemProperty присваеваем свойству CommandLine значение Notepad.exe } PropValue:= 'Notepad.exe'; MyProperty.Set_Value(PropValue); // После того, как все входные свойства определены, запускаем приложение. // OutParam - объект, возвращаемый методом ExecMethod_ OutParam:= Process.ExecMethod_('Create', InParam, 0, nil); // Получения выходных параметров из возвращённого объекта OutParam типа SWbemObject SProp1:= outParam.Properties_.Item('ReturnValue', 0); // Проверяю, удалось ли запустить приложение. Если свойство ReturnValue не равно 0, // то произошла ошибка. if SProp1.Get_Value = 0 then begin SProp2:= outParam.Properties_.Item('ProcessID', 0); Button2.Enabled:= True; Button1.Enabled:= False; sleep(300); SetForegroundWindow(Form1.Handle); end else MessageBox(0, PChar('Не удалось запустить приложение.'), PChar(Form1.Caption), MB_OK); end; procedure TForm1.Button2Click(Sender: TObject); var PropValue: OleVariant; begin SObject:= Service.Get('Win32_Process.Handle="' + WideString(SProp2.Get_Value) + '"', 0, nil); Method:= SOBject.Methods_.Item('Terminate', 0); InParam:= Method.InParameters.SpawnInstance_(0); MyProperty:= InParam.Properties_.Add('Reason', wbemCimtypeUint32, False, 0); PropValue:= 0; MyProperty.Set_Value(PropValue); OutParam:= SObject.ExecMethod_('Terminate', InParam, 0, nil); SProp1:= outParam.Properties_.Item('ReturnValue', 0); if SProp1.Get_Value = 0 then begin Button1.Enabled:= True; Button2.Enabled:= False; end else MessageBox(0, PChar('Не удалось закрыть приложение.'), PChar(Form1.Caption), MB_OK); end; procedure TForm1.Button3Click(Sender: TObject); var ObjectSet: ISWbemObjectSet; Enum: IEnumVariant; TempObj: OleVariant; Value: Cardinal; begin // Выключение компьютера - использование Shutdown без свойств. if MessageBox(0, PChar('Если вы выберете ''Да'', ваш компьютер выключится!'), PChar(Form1.Caption), MB_YESNO or MB_ICONEXCLAMATION or MB_DEFBUTTON2) = mrYes then begin Service:= SWbemLocator1.ConnectServer('.', 'root\cimv2', '', '', '', '', 0, nil); Service.Security_.Privileges.Add(wbemPrivilegeShutdown, True); // // SObject:= Service.Get('Win32_OperatingSystem', wbemFlagUseAmendedQualifiers, nil); // ObjectSet:= SObject.Instances_(0, nil); ObjectSet:= Service.ExecQuery('SELECT * FROM Win32_OperatingSystem WHERE Primary=True', 'WQL', wbemFlagReturnImmediately, nil); Enum:= (ObjectSet._NewEnum) as IEnumVariant; while (Enum.Next(1, TempObj, Value) = S_OK) do begin SObject:= IUnknown(tempObj) as SWBemObject; SObject.ExecMethod_('Shutdown', nil, 0, nil); end; end; { if MessageBox } end; end. |
Пояснения к коду: Примечание 1 Security_ - данное свойство используется в том случае, когда вы собираетесь считать или установить настройки безопасности для объекта SWbemServices. Объект SWbemSecurity имеет следующие свойства: AuthenticationLevel, ImpersonationLevel, Privileges. Нас в данном случае будет интересовать только второе свойство. ImpersonationLevel - Числовое значение. Данное свойство определяет, может ли процесс, владельцем которого является WMI, пользоваться правами вашей учётной записи, что может быть необходимо при обращении к другим процессам. Я буду пользоваться значением '3' (wbemImpersonationLevelImpersonate), что означает, что я наделяю данный объект правами того, кто его вызвал. Об остальных уровнях наследования прав читайте в SDK.
Примечание 2 Свойство Methods_ объекта SWbemObject представляет собой объект типа SWbemMethodSet, который является не чем иным, как коллекцией методов данного класса (или экземпляра класса).
Данное свойство предназначено только для чтения (read-only).
Единственный метод Item объекта SWbemMethodSet возвращает объект типа SWbemMethod.
Метод Item принимает следующие параметры: objMethod = Item( strName, [ iFlags = 0 ] ) strName - необходимый параметр. Имя метода, указатель на который должен быть возвращён данным методом.
Примечание 3 Свойство InParameters объекта SWbemMethod определяет входные параметры для данного метода. Метод SpawnInstance_ объекта SWbemObject создаёт новый экземпляр класса.
Данный метод имеет следующие входные параметры: objNewInstance = SpawnInstance_( [ iFlags = 0 ] ) Единственный параметр iFlags зарезервирован и не обязателен к указанию.
Если указывается, то должен быть равен 0.
Примечание 4 Свойство Properties_ объекта SWbemObject представляет собой объект типа SWbemPropertySet, который является коллекцией свойств для данного класса или экземпляра.
Метод Add объекта SWbemPrivilegeSet добавляет объект типа SWbemProperty к объекту SWbemPrivilegeSet.
Данный метод имеет следующие входные параметры: objProperty = Add( strName, iCIMType, [ bIsArray = FALSE ], [ iFlags = 0 ] )
Примечание 5 Для получения коллекции экземпляров Win32_OperatingSystem я намеренно воспользовался методом ExecQuery объекта ISWbemServices, что бы продемонстрировать работу данной ф-ии.
Использование данного метода равносильно используемой мною ранее конструкции.
Кстати, синтаксис WQL вам ничего не напоминает? ;) Правильно - WQL прямой потомок ANSI SQL, и соответствует синтаксису SQL. В WQL введены незначительные семантические изменения необходимые для работы с WMI. Так что вам даже не придётся учить новый язык запросов, для того что бы использовать WMI - Microsoft оказалась гуманной и мудрой в этом отношении и в очередной раз не усложнила нашу жизнь :)
Для интересующихся правилами составления запросов: откруваем SDK, раздел "Querying with WQL", всё понятно и доступно.
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ UseMethods и \Exe-files соответственно.
Примечание 1: Описание констант MapInfo (Global.pas)
Примечание - данный файл был взят мной с Интернета. Хочу сразу сделать предупреждение - разработчики MapInfo заявляют что набор констант может быть подвергнут изменениям в следующих редакциях MapInfo.Данный набор констант адаптирован под пятую версию. К сожалению шестой версии у меня нет (может кто поделиться ;-) ) и соответственно нет возможности проверить изменился ли набор констант или нет.Вот в принципе и все что нужно для работы с MapInfo в Delphi, дерзайте
Скачать компонент (527 К)
2002 год.
Специально для
Пример
Рассмотрим более сложный пример - шаблон дерева для базовых типов языка (атомарных - числовых, строковых, указателей, перечислымых и множеств; конструируемых - записей и массивов). Дерево состоит из узлов (nodes), каждый из которых содержит список подчинённых ему узлов дерева, ссылку на следующий элемент по списку родительского узла, ссылку на следующий по списку всех узлов, ссылку на родительский узел и собственно данные узла. Этот шаблон использует шаблон "несамостоятельного" списка (inferior list), состоящий из двух частей - шаблона типа, и шаблона процедур списка. Модули, полученные в результате инстанциации этих шаблонов, используются в модуле, полученном в результате инстанциации шаблона дерева прямым включением (директива компиллятора "{$I ...}"). Учитывая вложенность шаблонов скрипт temss нужно запустить два раза. Ниже приведён отрывок файла README из прилагаемого к статье архива с перечислением файлов, относящихся к данному примеру:| inferiorlist_type.tem Шаблон "несамостоятельного" списка temss1.out temss2.out Снимки протоколов первого и второго прохода препроцессора для модуля xTree.pas tree.tem Шаблон дерева treeStr.pas treeStr_AllNodes_Procs.pas treeStr_AllNodes_Type.pas treeStr_NodesList_Procs.pas treeStr_NodesList_Type.pas Инстант дерева для типа типа String xTree.exe xTree.pas Пример использования шаблона дерева EXE слинкован с runtime-пакетами (Delphi 3.0) ! |
Описанный выше шаблон дерева может быть использован и для хранения объектов, но о деструкции объектов в этом случае придётся позаботиться самостоятельно. Лучшим решением было бы написание отдельного шаблона дерева для объектов (возможно с использованием этого шаблона), обеспечивающего автоматическую деструкцию объектов.
Запуск и связывание с сервером MapInfo
Итак рассмотрим простейший компонент для запуска и управления MapInfo (TKDMapInfoServer),следует заметить что мной не ставилась написание специализированного компонента - я представляю основы. unit KDMapInfoServer; interface uses ComObj,Controls,Variants,ExtCtrls,Windows,Messages,SysUtils,Classes; const scMapInfoWindowClass = 'xvt320mditask100'; icWinMapinfo = 1011; icWinInfoWindowid = 13; type TEvalResult = record AsVariant: OLEVariant; AsString: String; AsInteger: Integer; AsFloat: Extended; AsBoolean: Boolean; end; TKDMapInfoServer = class(TComponent) private // Владелец FOwner : TWinControl; // OLE сервер FServer : Variant; FHandle : THandle; FActive : Boolean; FPanel : TPanel; Connected : Boolean; MapperID : Cardinal; MapperNum : Cardinal; procedure SetActive(const Value: Boolean); procedure SetPanel(const Value: TPanel); procedure CreateMapInfoServer; procedure DestroyMapInfoServer; { Private declarations } protected { Protected declarations } public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; // Данная процедура выполеняет метод сервера MapInfo - Do procedure ExecuteCommandMapBasic(Command: String; const Args: array of const); // Данная процедура выполеняет метод сервера MapInfo - Eval function Eval(Command: String; const Args: array of const): TEvalResult; virtual; procedure WindowMapDef; procedure OpenMap(Path : String); published { Published declarations } // Создает соединение с сервером MapInfo property Active: Boolean read FActive write SetActive; property PanelMap : TPanel read FPanel write SetPanel; end; procedure Register; implementation procedure Register; begin RegisterComponents('Kuzan', [TKDMapInfoServer]); end; { TKDMapInfoServer } constructor TKDMapInfoServer.Create(AOwner: TComponent); begin inherited Create(AOwner); FOwner := AOwner as TWinControl; FHandle := 0; FActive := False; Connected := False; end; destructor TKDMapInfoServer.Destroy; begin DestroyMapInfoServer; inherited Destroy; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.CreateMapInfoServer; begin try FServer := CreateOleObject('MapInfo.Application'); except FServer := Unassigned; end; // Скрываем панели управления MapInfo ExecuteCommandMapBasic('Alter ButtonPad ID 4 ToolbarPosition (0, 0) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 3 ToolbarPosition (0, 2) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 1 ToolbarPosition (1, 0) Show Fixed', []); ExecuteCommandMapBasic('Alter ButtonPad ID 2 ToolbarPosition (1, 1) Show Fixed', []); // Переопределяем окна ExecuteCommandMapBasic('Close All', []); ExecuteCommandMapBasic('Set ProgressBars Off', []); ExecuteCommandMapBasic('Set Application Window %D', [FOwner.Handle]); ExecuteCommandMapBasic('Set Window Info Parent %D', [FOwner.Handle]); FServer.Application.Visible := True; if IsIconic(FOwner.Handle)then ShowWindow(FOwner.Handle, SW_Restore); BringWindowToTop(FOwner.Handle); end; procedure TKDMapInfoServer.DestroyMapInfoServer; begin ExecuteCommandMapBasic('End MapInfo', []); FServer := Unassigned; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.ExecuteCommandMapBasic(Command: String; const Args: array of const); begin if Connected then try FServer.Do(Format(Command, Args)); except on E: Exception do MessageBox(FOwner.Handle, PChar(Format('Ошибка выполнения () - %S', [E.Message])),'Warning',MB_ICONINFORMATION OR MB_OK); end; end; //------------------------------------------------------------------------------ function TKDMapInfoServer.Eval(Command: String; const Args: array of const): TEvalResult; Function IsInt(Str : String): Boolean; var Pos : Integer; begin Result := True; For Pos := 1 To Length(Trim(Str)) do begin IF (Str[Pos] <> '0') and (Str[Pos] <> '1') and (Str[Pos] <> '2') and (Str[Pos] <> '3') and (Str[Pos] <> '4') and (Str[Pos] <> '5') and (Str[Pos] <> '6') and (Str[Pos] <> '7') and (Str[Pos] <> '8') and (Str[Pos] <> '9') and (Str[Pos] <> '.') Then Begin Result := False; Exit; end; end; end; var ds_save: Char; begin if Connected then begin Result.AsVariant := FServer.Eval(Format(Command, Args)); Result.AsString := Result.AsVariant; Result.AsBoolean := (Result.AsString = 'T') OR (Result.AsString = 't'); IF IsInt(Result.AsVariant) Then Begin try ds_save := DecimalSeparator; try DecimalSeparator := '.'; Result.AsFloat := StrToFloat(Result.AsString);//Result.AsVariant; finally DecimalSeparator := ds_save; end; except Result.AsFloat := 0.00; end; try Result.AsInteger := Trunc(Result.AsFloat); except Result.AsInteger := 0; end; end else Begin Result.AsInteger := 0; Result.AsFloat := 0.00; end; end; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.SetActive(const Value: Boolean); begin FActive := Value; IF FActive then begin CreateMapInfoServer; WindowMapDef; Connected := True; end else begin IF Connected then begin DestroyMapInfoServer; Connected := False; end; end; end; //------------------------------------------------------------------------------ procedure TKDMapInfoServer.SetPanel(const Value: TPanel); begin FPanel := Value; end; procedure TKDMapInfoServer.WindowMapDef; begin ExecuteCommandMapBasic('Set Next Document Parent %D Style 1', [FPanel.Handle]); end; procedure TKDMapInfoServer.OpenMap(Path: String); begin ExecuteCommandMapBasic('Run Application "%S"', [Path]); MapperID := Eval('WindowInfo(FrontWindow(),%D)',[12]).AsInteger; with PanelMap do MoveWindow(MapperID, 0, 0, FPanel.ClientWidth, FPanel.ClientHeight, True); end; end. И так что мы имеем -Благодарности
Скачать архив : (8 К)
Архив Src.ZIP содержит все упомянутые в статье скрипты и исходные модули.
Perl-модули отлажены и проверены в среде Windows c Perl 5.6.1 (инсталляция собственной сборки с MinGW32 - GNU C 2.95.3-4).
Гусев А.В.
А теперь о перемещениях.
Существуют 2 вида перемещений мыши с помощью клавиатуры: явные-визуальные и событийные (компонентов). 1. Явные перемещения мыши производятся объектом Mouse Что бы переместить мышь в любую область экрана нужно написать: Mouse.CursorPos:=point(0,0) Размеры экрана мы знаем из объекта Screen.Вызвать нажатие кнопки можно : SendMessage(Button1.handle, BM_CLICK, 0, 0); 2. Вызов СОБЫТИЙ перемещения и нажатий кнопок мыши. Это то, что нам и нужно для программирования интерфейсов в VCL. а) Нужно получить доступ к процедурам обрабатывающим события мыши. Как правило они находятся в приватной секции и доступ к ним осуществляется в эмуляции создания класса-наследника. Type HackSplitter=class(TSplitter); // кто не знает Доступ к приватным методам осуществляется так: HackSplitter(SplitterLeft).MouseDown
А теперь рабочий пример:
Замечание:
Обработчик эмуляции мыши нужно обязательно ставить на TForm указав свойство KeyPreview:=true в инспекторе объектов.
const iInc:byte=1;// медленное перемещение iIncSpeed:byte=10; // быстрое перемещение iStartSpeed:byte=10;// счетчик когда вкл быстрое перемещение var bDown:boolean; mX,mY, // перемещения мыши iIncCountL,iIncCountR:integer; // счетчики Type HackSplitter=class(TSplitter); // доступ к протект свойствам procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;Shift: TShiftState); Procedure SetSplit; // процедура установки события MouseDown var iSysCaption:integer; // размер заголовка окна begin bDown:=True; // мы нажали мышь // получили высоту заголовка iIncCountL:=0;iIncCountR:=0; // сброс счетчиков iSysCaption:=GetSystemMetrics(SM_CYCAPTION); // размер высоты заголовка mX:=SplitterLeft.Left+2; // записали позицию SplitterLeft mY:=SplitterLeft.Top; // вызвали событие нажатия кнопки в позиции над SplitterLeft HackSplitter(SplitterLeft).MouseDown(mbLeft,Shift+[ssLeft],mX,mY); end; begin case Key of VK_LEFT://PanelLeft.Width:=PanelLeft.Width-20; - вот оно "грязное перемещение" первого варианта, попробуйте для примера и его :) begin If ssShift in Shift then // перемещаем на ssShift begin If not bDown then SetSplit; // Эмуляция события нажатия кнопки // Выставляем впереди, а не по begin else begin, потому что // нужно обрабатывать еденичные перемещения If iIncCountL>iStartSpeed then // время включения "скоростного" перемещения mX:=mX-iIncSpeed else mX:=mX-iInc; //mY:=mY - по высоте мы не перемещаем HackSplitter(SplitterLeft).MouseMove(Shift+[ssLeft],mX,mY); iIncCountR:=0; // счетчики inc(iIncCountL); end; end; VK_RIGHT://PanelLeft.Width:=PanelLeft.Width+20; begin If ssShift in Shift then begin If not bDown then SetSplit; If iIncCountR>iStartSpeed then mX:=mX+iIncSpeed else mX:=mX+iInc; HackSplitter(SplitterLeft).MouseMove(Shift+[ssLeft],mX,mY); iIncCountL:=0; inc(iIncCountR); end; end; end; end; procedure TForm1.FormShow(Sender: TObject); begin bDown:=False;// авто сброс end; procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin If bDown and (not (ssCtrl in Shift)) then begin bDown:=False; HackSplitter(SplitterLeft).MouseUp(mbLeft,Shift+[ssLeft],mX,mY); end; end; Замечание при использования перемещения 2-х TSplitter одновременно.
Когда я сделал тестовый пример, где 2 TSplitter были в виде "прицела", в рабочей форме, это вызывало переполнение стека после изменения размеров. С каким компонентом происходил "конфликт" или между самими TSplitter я не разбирался, просто сделал переключатель на монопольное перемешение одного TSplitter.
Переполнение исчезло.
Шевченко Владимир aka AWS
сентябрь 2002г.
Специально для
А теперь - примеры.
Разумеется, вам нужно вставить в секцию uses модуль ShellAPI, в котором определена функция SHFileOperation.Рассмотрим самое простое - удаление файлов.
procedure TForm1.Button1Click(Sender: TObject); var SHFileOpStruct : TSHFileOpStruct; From : array [0..255] of Char; begin SetCurrentDirectory( PChar( 'C:\' ) ); From := 'Test1.tst' + #0 + 'Test2.tst' + #0 + #0; with SHFileOpStruct do begin Wnd := Handle; wFunc := FO_DELETE; pFrom := @From; pTo := nil; fFlags := 0; fAnyOperationsAborted := False; hNameMappings := nil; lpszProgressTitle := nil; end; SHFileOperation( SHFileOpStruct ); end; Обратите внимание, что ни один из флагов не установлен. Если вы хотите не просто удалить файлы, а переместить их в корзину, должен быть установлен флаг FOF_ALLOWUNDO.
Для удобства дальнейших экспериментов напишем функцию, создающую из массива строк буфер для передачи его в качестве параметра pFrom. После каждой строки в буфер вставляется нулевой байт, в конце списка - два нулевых байта. type TBuffer = array of Char; procedure CreateBuffer( Names : array of string; var P : TBuffer ); var I, J, L : Integer; begin for I := Low( Names ) to High( Names ) do begin L := Length( P ); SetLength( P, L + Length( Names[ I ] ) + 1 ); for J := 0 to Length( Names[ I ] ) - 1 do P[ L + J ] := Names[ I, J + 1 ]; P[ L + J ] := #0; end; SetLength( P, Length( P ) + 1 ); P[ Length( P ) ] := #0; end; Выглядит ужасно, но работает. Можно написать красивее, просто лень.
И, наконец, функция, удаляющая файлы, переданные ей в списке Names. Параметр ToRecycle определяет, будут ли файлы перемещены в корзину или удалены. Функция возвращает 0, если операция выполнена успешно, и ненулевое значение, если руки у кого-то растут не из того места, и этот кто-то всунул функции имена несуществующих файлов. function DeleteFiles( Handle : HWnd; Names : array of string; ToRecycle : Boolean ) : Integer; var SHFileOpStruct : TSHFileOpStruct; Src : TBuffer; begin CreateBuffer( Names, Src ); with SHFileOpStruct do begin Wnd := Handle; wFunc := FO_DELETE; pFrom := Pointer( Src ); pTo := nil; fFlags := 0; if ToRecycle then fFlags := FOF_ALLOWUNDO; fAnyOperationsAborted := False; hNameMappings := nil; lpszProgressTitle := nil; end; Result := SHFileOperation( SHFileOpStruct ); Src := nil; end; Обратите внимание, что мы освобождаем буфер Src простым присваиванием значения nil. Если верить документации, потери памяти при этом не происходит, а напротив, происходит корректное уничтожение динамического массива. Каким образом, правда - это рак мозга :-).
Проверяем : procedure TForm1.Button1Click(Sender: TObject); begin DeleteFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], True ); end; Вроде все работает.
Кстати, обнаружился забавный глюк - вызовем процедуру DeleteFiles таким образом: procedure TForm1.Button1Click(Sender: TObject); begin SetCurrentDirectory( PChar( 'C:\' ) ); DeleteFiles( Handle, [ 'Test1', 'Test2' ], True ); end; Файлы 'Test1' и 'Test2' удаляются совсем, без помещения в корзину, несмотря на установленный флаг FOF_ALLOWUNDO. Мораль: при использовании функции SHFileOperation используйте полные пути всегда, когда это возможно.
Ну, с удалением файлов разобрались.
Теперь очередь за копированием и перемещением.
Следующая функция перемещает файлы указанные в списке Src в директорию Dest. Параметр Move определяет, будут ли файлы перемещаться или копироваться. Параметр AutoRename указывает, переименовывать ли файлы в случае конфликта имен. function CopyFiles( Handle : Hwnd; Src : array of string; Dest : string; Move : Boolean; AutoRename : Boolean ) : Integer; var SHFileOpStruct : TSHFileOpStruct; SrcBuf : TBuffer; begin CreateBuffer( Src, SrcBuf ); with SHFileOpStruct do begin Wnd := Handle; wFunc := FO_COPY; if Move then wFunc := FO_MOVE; pFrom := Pointer( SrcBuf ); pTo := PChar( Dest ); fFlags := 0; if AutoRename then fFlags := FOF_RENAMEONCOLLISION; fAnyOperationsAborted := False; hNameMappings := nil; lpszProgressTitle := nil; end; Result := SHFileOperation( SHFileOpStruct ); SrcBuf := nil; end; Ну, проверим. procedure TForm1.Button1Click(Sender: TObject); begin CopyFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], 'C:\Temp', True, True ); end; Все в порядке (а кудa ж оно денется).
Есть, правда еще одна возможность - перемещать много файлов каждый в свою директорию за один присест, но я с трудом представляю, кому это может понадобиться.
Осталась последняя операция - переименование. function RenameFiles( Handle : HWnd; Src : string; New : string; AutoRename : Boolean ) : Integer; var SHFileOpStruct : TSHFileOpStruct; begin with SHFileOpStruct do begin Wnd := Handle; wFunc := FO_RENAME; pFrom := PChar( Src ); pTo := PChar( New ); fFlags := 0; if AutoRename then fFlags := FOF_RENAMEONCOLLISION; fAnyOperationsAborted := False; hNameMappings := nil; lpszProgressTitle := nil; end; Result := SHFileOperation( SHFileOpStruct ); end;
И проверка ...
procedure TForm1.Button1Click(Sender: TObject); begin RenameFiles( Handle, 'C:\Test1' , 'C:\Test3' , False ); end; Пока все ...
Mодуль (3K) прилагается.
ADO и файлы формата MS Access
- Учитель, почему ты обманул меня? Ты сказал, что Вейдер предал и убил моего отца, а теперь оказалось, что он и есть мой отец!- Твой отец… Его соблазнила темная сторона силы. Он больше не был Анекином Скайукером и стал Дартом Вейдером. Поэтому хороший человек, который был твоим отцом, был уничтожен. Так что, то, что я тебе сказал, было правдой… с определенной точки зрения…
- С определенной точки зрения?
- Люк… ты вот увидишь сам… что очень многие истины зависят от нашей точки зрения.
(Звездные войны. Эпизод 6.)
К чему я привел эту цитату - в результате всей этой работы я пришел к выводу, что у нас, программистов, и у Microsoft разный взгляд на фразу 'Обеспечивается доступ к данным'. Мы (ну или, по крайней мере, я) в этой фразе видим следующее содержание 'обеспечивается доступ к данным для их просмотра и РЕДАКТИРОВАНИЯ (т.е. редактирование, удаление и добавление новых данных)'. Что имеет в виду Microsoft можно только догадываться, но явно, что без особых проблем достигается только просмотр данных. Кроме того, практически все примеры в литературе ограничиваются получением данных именно для просмотра, после чего следует несколько бодрых фраз и все заканчивается. Как говорится выше - разные точки зрения…
Итак, прежде всего, работа была ограничена условием разработки в Delphi 4. Причин этому много, но к этой статье это отношения не имеет. Просто - программа, разработанная в Delphi 4 должна работать через ADO. Поэтому приступили к поиску компонент, обеспечивающих такую работу. Нашли их довольно много, как платных, так и бесплатных. Все, что будет написано, одинаково и для всех вариантов и даже для Delphi5. Исключение составляет только работа с закладками в Delphi 5.
ADO была взята на тот момент самая последняя версия с сайта Microsoft - это ADO 2.6.
Итак, возьмем файл mdb формата MS Access 97. Его можно сделать с помощью хотя бы самого Access. И создадим там небольшую таблицу, к примеру, такую:
А теперь давайте, вообразим себя пользователями и попробуем что-нибудь исправить или добавить. Например, добавим несколько пустых записей и попробуем внести туда данные. Добавляем. Нормально. Теперь внесем данные и нажмем POST. И что мы видим?
Ага. Интересно, а при чем тут ключ, если у нас на таблицу ключ не наложен? Пробуем добавить новую запись, удалить запись без Object_ID. Результат одинаков - все то же сообщение об ошибке. И что же делать? Запускаем MS Access, пробуем там, и видим, что там все отлично. Стало быть, что-то не так мы делаем с ADO. И тут мы вспоминаем, что когда мы создавали таблицу в MS Access, он предлагал создать ключевые поля для этой таблицы. А после долгих поисков в ADO SDK я нашел этому такое объяснение: ADO предполагает, что таблица будет в первой нормальной форме. Если кто не помнит главное требование первой формы - отсутствие повторяющихся записей.
В данном случае мы не можем создать ключ на то, что есть. Что же делать? И тут приходит на ум простое решение: добавим еще одно поле, чтобы каждая запись была однозначно определена (т.е. некий внутренний идентификатор). Чтобы не думать о содержимом этого нового поля, делаем совсем просто - пусть это будет автоинкрементное поле, и создадим на него первичный ключ. Отлично! Делаем - все работает. Пока мы не добавляем больше одной записи. Если мы их добавим подряд несколько, мы увидим очень интересную ситуацию как на картинке.
Что здесь интересного? А то, что содержимое Internal_ID для всех этих записей равно нулю, хотя это автоинкрементное поле! И Table.Refresh здесь не помогает! Только закрытие и последующее открытие таблицы приводит к тому, что мы видим то, что и ожидалось.
А пока мы не имеем правильных идентификаторов, наличие такого поля не дает ничего. Выше приведенные ошибки будут продолжать сыпаться как из рога изобилия. Но вот только закрывать - открывать таблицу каждый раз после добавления новой записи для того, чтобы автоинкрементное поле принимало правильные значения - это сильно. Так не пойдет. Вот так ADO, подумал я, а давай-ка попробуем MS Access 2000. И тут оказалось, что там все нормально работает: добавляем запись, делаем сохранение (Post) автоинкрементное поле тут же принимает правильное значение.
В результате я могу сделать только один вывод - Microsoft активно, всеми доступными средствами, пытается заставить пользователей переходить к своим новым продуктам.
А вот почему в Access все нормально работает - это загадка. Я думаю, что сам-то он пользуется какими-то своими методами, либо в процессе работы у него есть некий идентификатор записи типа только что придуманного нами.
Ну а чтобы пользователь не видел этого внутреннего идентификатора (он ведь нужен только нам) делаем это поле невидимым. Надеюсь, что все знают, что это делается через TField.Visible := FALSE.
Кто-нибудь может возразить: а зачем нам такой идентификатор, мы можем записи идентифицировать по каким-нибудь своим полям. Ради Бога! Но тут есть еще одна проблема и эта проблема называется закладки.
Проблемы закладок нет в Delphi 5, потому что там вокруг Bookmark сделан класс ими управляющий, а я имею в виду работу с закладками через ADO. Смотрим опять же в ADO SDK и видим там такое описание: 'Recordset.Bookmark: Устанавливает или возвращает закладку, которая однозначно определяет текущую запись в Recordset. При создании или открытии объекта Recordset каждая из его записей получает уникальную закладку. Для того чтобы запомнить положение текущей записи, следует присвоить текущее значение свойства Bookmark переменной. Для быстрого возвращения к сохраненному в переменной указателю текущей записи в любое время после перехода на другую запись следует указать в значении свойства Bookmark объекта Recordset значение этой переменной'. Казалось бы, какие проблемы? А вот какие: возвращаемое значение всегда одно и тоже для любой записи. И когда мы устанавливаем этот, с позволения сказать, Bookmark, ничего не происходит. И только наш внутренний идентификатор поможет в такой ситуации, кроме того, его значение всегда имеет смысл, даже после закрытия и повторного открытия таблицы, что, в общем-то, удобно.
После того как все заработало, я решил проверить скорость работы ADO. У нас может быть ситуации, когда в таблицу добавляется сразу большое количество записей, к примеру, 50-60 тысяч записей за раз. Так вот, когда использовалась BDE, такая операция занимала максимум 10 минут. Угадайте, чему стало равно это время при использовании ADO? Минимум 25 минут на той же самой машине. Если после этого мне будут говорить, что ADO быстрее BDE чуть ли не в 2 раза - позвольте мне с Вами не согласиться.
Итак, для нормальной работы мы должны иметь таблицы в первой нормальной форме, для этого делаем автоинкрементное поле с уникальным индексом. Кроме того, если мы можем добавлять больше одной записи за один раз и потом сразу возможно будем их редактировать, нам надо использовать файлы MS Access 2000.
ADO и файлы xBASE и Paradox
Итак, мы смогли наладить работу через ADO к файлам формата MS Access. Но ведь мы можем и должны использовать файлы xBase и Paradox в качестве обменных файлов.Попробуем это сделать. Все примеры какие я видел в книгах работают одинаково - через 'Microsoft OLE DB provider for ODBC'. А все редакторы, которые делают строку подключения, всегда показывают только mdb файлы в диалоге, в котором задается путь к файлу БД. Что-то тут нечисто, подумал я - а как же тот же самый Access это делает? Ведь явно не через ODBC, стало быть, есть какая-то хитрость.
После примерно недельных поисков в Интернете решение было найдено. Да, действительно можно использовать 'Microsoft Jet 4.0 OLE DB Provider'. Чтобы не рассказывать долго, представим, что у нас на диске D в корне лежит файл Test.dbf формата dBase 5.0.
Строка коннекта для этого случая будет выглядеть так:
'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\; Extended Properties=dBase 5.0; Mode=Read|Write|Share Deny None; Persist Security Info=True';
И это все. Самое интересное во всей это строке - секция 'Extended Properties'.
Чтобы знать, что конкретно для разных форматов надо писать в Extended properties, загляните в реестр Windows на следующую ветку:
HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\ISAM Formats
Там перечислены все поддерживаемые в данном случае форматы.
После опытов над форматом dbf оказалось, что все выше сказанное для формата mdb совершенно не относится к этому формату - и все требования про первую форму можно и не соблюдать! В общем, загадка природы.
А вот формат Paradox - это оказалась песня на меньшая, чем mdb. И вот почему - здесь все требования о первой форме таблицы в действии, но ведь мы не можем создавать таблицу, потом говорить пользователю 'Слышь, мужик, а теперь метнулся, запустил Paradox и создал первичный ключ на эту таблицу. А потом нажмешь на ОК и мы продолжим'. Это несерьезно. Стало быть, этот ключ надо создавать нам самим.
Хорошо, запускаем справку по MS Jet SQL и ищем раздел создания индексов или первичных ключей. Находим следующее: CREATE INDEX имя_индекса ON название_таблицы (название_поля) WITH PRIMARY. ALTER TABLE название_таблицы ADD CONSTRAINT имя_ограничения PRIMARY KEY (название_поля) Все далее сказанное абсолютно одинаково для обоих вариантов.
Предположим, что наша таблица называется ExpTbl.db и поле, на которое мы хотим наложить первичный ключ, называется IntrernalID. Хорошо, подключаемся к таблице и задаем такую строку SQL для исполнения: CREATE INDEX My_Index ON ExpTable (InternalID) WITH PRIMARY
Запустим на выполнение. Ого, а что это мы видим? Вот те на - очередное сообщение об ошибке. При этом сообщение как всегда очень содержательное применительно к нашему случаю.
Вывод один - опять очередное требование ADO, которое сразу не поймешь. Ладно, запускаем он-лайн MS MSDN и делаем запрос на PARADOX. Видим что-то около 50 документов. И где-то в 35-36 документе я нашел ответ маленькими буковками внизу экрана! Сейчас я вам скажу в чем проблема - держитесь крепче: имя первичного ключа должно совпадать с названием таблицы, а имена индексов с именами полей. Неслабо.
Исправляем SQL: CREATE INDEX ExpTable ON ExpTable (InternalID) WITH PRIMARY Запускаем, смотрим - все отлично.
Чтобы никто больше мучился с этим делом, я хотел бы привести самые значащие ограничения для драйвера PARADOX, которые я нашел в MSDN:
Итак, для работы через ADO с файлами xBase или Paradox, нам необходимо указывать нужный драйвер в секции Extended Properties и в секции Data Source только путь до файла. Для xBase на этом все трудности закончены, а вот для Paradox необходимо задание первичного ключа как для формата MS Access, при этом есть определенные ограничения при задании названий ключей, так же как и возможных индексов.
То, о чем речь пойдет далее уже не относится к организации работы с таблицами xBase и Paradox через ADO, а скорее упоминание об одном полезном опыте.
Для добавления данных в эти таблицы, мы можем вставлять их по одной (Table.Append (Insert); Table.Post), а можем воспользоваться вариантом SELECT … INTO, INSERT … INTO. Поговорим теперь именно о втором варианте работы.
Смотрим файл справки MS Jet SQL. SELECT поле_1 [, поле_2 [, ...]] INTO новаяТаблица [IN внешняяБазаДанных] FROM источник
Ладно, пробуем. Пусть мы имеем в качестве источника данных mdb файл и хотим сохранить данные из таблицы SourceTable в таблицу формата Paradox 7.0 TestTable.db, расположенную в корне диска D:. Казалось бы: SELECT * INTO [TestTable.DB] IN 'D:\' FROM SourceTable
Нет, очередная ошибка. Вот, что мы видим.
Получим очередное сообщение об ошибке.
Ага, стало быть, файл для экспорта должен уже существовать? Ладно, не проблема, давайте создадим его и попробуем еще раз.
Ну, в общем, желающие могут еще поэкспериментировать, а для остальных я скажу как делается: SELECT * INTO [Paradox 7.x;DATABASE=D:\].[TestTable#DB] FROM SourceTable
Создавать таблицу до операции экспорта нет надобности - таблица будет создана автоматически, все поля будут созданы правильного типа. В получившейся таблице будут все данные из SourceTable.
Единственная проблема - Вы не сможете больше редактировать данные в этой таблице, потому (см. выше) для этого необходим первичный ключ, а создать его для таблицы, в которой уже есть записи нельзя.
Самое потрясающее это название раздела MSDN, где я нашел этот ответ - 'Как, используя ADO, открыть таблицу Paradox, защищенную паролем'. Как ЭТО имеет отношение к этому синтаксису SQL, я так и не понял, честно говоря.
Вот, в общем-то, все, что я хотел написать. Осталось еще много интересного в этой области. Чего стоит, например установка правильных кодовых страниц для результирующих файлов и много чего подобного. Это тема либо для продолжений этой статьи, либо для отдельных статей. Очень надеюсь, что кто-нибудь нашел тут полезные для себя сведения.
Иванов Денис Михайлович.
14 мая 2001г.
Специально для
При написании статьи использовались следующие материалы:
Алгоритм обхода препятствий.
| Раздел Подземелье Магов | Алексей Моисеев , дата публикации 10 апреля 2000 г. |
Примечание:
Данный материал не является аналитическим, в нем не описываются особенности алгоритма, оценки его эффективности и т.д.
Автором предоставлен проект реализующий этого алгоритм и краткое пояснение к конкретной реализации.
Елена Филиппова
Предлагаемый алгоритм обхода препятствий - это, так называемый, обобщенный алгоритм Дейкстры. В англоязычной литературе он называется алгоритмом A*.
Реализация алгоритма: (191 К)
Алгоритм этот проще реализовать, чем описать:
Start - начальная клетка
Finish - конечная клетка.
Алгоритм итерационный
1 шаг: Помечаем Start как граничную точку.
2 шаг: Среди всех граничных точек находим Клетку1 - клетку с минимальной суммой оценки пройденного пути g и оценки оставшегося пути h.
3 шаг: Для Клетки 1 рассматриваем соседей. Если сосед имеет статус непосещенного, то мы обозначаеми его как граничную клетку, и указываем Клетку1 как предыдущую для него. Оценку g1 для соседа принимаем равной g+p, где p-стоимость прохождения по клетке сосед, а g - оценка пройденного пути для Клетки1 . Оценка h для любой клетки равна длине кратчайшего пути (по прямой от рассматриваемой клетки до клетки Finish) Рассматриваемую Клетку1 помечаем как отброшенную.
4 шаг: Если на предыдущем шаге один из соседей оказался равен клетке Finish, то путь найден. Если ни одного нового соседа не существует, то нет и пути.
5 шаг: Переход на шаг 2.
Буду рад любым предложениям по оптимизации, так как меня, к сожалению, не устраивает быстродействие.
Альтернатива
Есть, конечно, альтернатива User таймерам - это ожидаемые таймера, реализованные в ядре и поэтому менее тяжеловесные и более надежные. Они не посылают сообщений и должны ожидаться с помощью функции WaitForSingleObject или подобной. К ним имеют прямое отношение следующие функции API:CreateWaitableTimer SetWaitableTimer CancelWaitableTimer
Но, к сожалению, эти функции реализованы только в Windows NT/2000 и, следовательно не подходят для программы, рассчитанной на любую платформу Win32.
Архитектура микшера.
Нам важно различать две "ипостаси" микшера: аппаратную и программную. Обе стороны похожи, но есть и некоторые различия, о которых лучше знать.Архитектура платформы
Платформа реализована по схеме клиент - сервер на СУБД MS SQL Server 2000. Перевести ее в разряд трехуровневой архитектуры – голубая мечта понять основную идею архитектуры платформы из описания ее функционирования. А уж потом перейдем к описанию ее программных элементов.Платформа имеет два режима запуска: КОНФИГУРАТОР и ПОЛЬЗОВАТЕЛЬСКИЙ РЕЖИМ, напоминая чем -то 1С. Идея этих режимов действительно навеяна 1С.
В любом из этих двух режимов производится одинаковая работа по формированию в памяти набора специальных структур для хранения системной информации. Этот набор создается по информации из системной базы данных, загружаемой с SQL-сервера.
Для управления процессами загрузки структур и манипулирования ими в памяти при работе приложения созданы две специальные компоненты, структура которых в предельно сжатом виде приводится ниже, а более подробные версии имеются в прилагаемом учебном приложении.
К сожалению, пока нельзя похвастаться тем, что эти компоненты могут быть установлены в палитру Delphi, - они используются путем включения соответствующих модулей реализации в проект приложения, т.к. в силу исторических причин, в этих компонентах имеются функции, которые следовало бы вынести. Как говорится до этого еще не дошли руки.
Первая компонента (TDbInterface – интерфейс баз данных) ведает обработкой структур памяти, хранящих информацию о пользовательской базе данных, включая информацию о запросах и некоторых других объектах, о которых речь впереди.
| TDbInterface = class (TComponent) private FDatabaseName : String; // Список указателей на структуры категорий информации FInfoCategoryList : TInfoCategoryList; // Список указателей на структуры таблиц FTablesList : TList; // Список имен таблиц FTableNames : TStrings; // Список ссылок на комбинированные типы данных FFbCommonTypeList : TFbCommonTypeList; // Тип драйвера доступа к данным FDrvType : TDrvType; // Загрузка системной информации - установка имени FDatabaseName Procedure Set_DatabaseName(Value : String); public Constructor Create(AOwner : TComponent); Override; Destructor Destroy; Override; // Создание новой структуры таблицы Function New_pTTableInfo(ATableName : String; AUpdateTypes : Boolean) : pTTableInfo; // Создание новой структуры поля Function New_pTFieldInfo : pTFieldInfo; // Освобождение памяти, занятой структурой таблицы Function Dispose_pTTableInfo(ApTTableInfo: pTTableInfo; ADisposeFields, AUpdateTypes : Boolean): Bool; // Освобождение памяти, занятой структурой поля Function Dispose_pTFieldInfo(ApTFieldInfo: pTFieldInfo): Bool; Property TablesList : TTablesList read FTablesList; // Список категорий информации БД Property FbCommonTypeList : TFbCommonTypeList read FFbCommonTypeList; Property InfoCategoryList : TInfoCategoryList read FInfoCategoryList; // Новая таблица, поле published Property DrvType : TDrvType read FDrvType write FDrvType; Property DatabaseName : String read FDatabaseName write Set_DatabaseName; end; |
Вторая компонента (TArmInterface – интерфейс системы управления) ведает обработкой структур памяти, хранящих информацию о специальных атрибутах, так называемых элементах системы управления (СУ), из которых создается главное меню рабочего места.
| TArmInterface = class (TObject) private FDatabaseName : String; FFbSUObjectL : TFbSUObjectList; // Обобщенный список элементов СУ FFbMedTreeV : TTreeView; // Дерево конфигурации АРМ FArmMainMenu : TMainMenu; // Главное меню конфигурации АРМ FForm : TForm; FDbInterface : TDbInterface; // Загрузка системной информации - установка имени FDatabaseName Procedure Set_DatabaseName(Value : ShortString); // Запуск прикладной функции, вызываемой по номеру ID - приводится в // действие при выборе пункта меню, по значению его свойства Tag Procedure StartFb_Procedure(Sender : TObject); Public // Создание структуры TFbSUObject и возврат ссылки на нее Function New_pTFbSUObject(AFbSUType : TFbSUType) : pTFbSUObject; // Освобождение памяти, занимаемой структурой TFbSUObject по ссылке Procedure Free_pTFbSUObject(ApTFbSUObject: pTFbSUObject); // Создание меню АРМ по информации в FFbMedTreeV Procedure LoadArmMenu(ApTFbSUObject : pTFbSUObject); published Property DatabaseName : String read FDatabaseName write Set_DatabaseName; Property DbInterface : TDbInterface read FDbInterface write Set_FDbInterface; end; |
В обоих компонентах есть ключевая операция – установка имени поля FDatabaseName, которая приводит в действие процедуру Set_DatabaseName. При загрузке приложения сначала нужно создать экземпляр TDbInterface, т.к. в компоненте TArmInterface нужно указывать ссылку FDbInterface на существующий экземпляр TDbInterface.
В процессе выполнения процедуры Set_DatabaseName осуществляются следующие действия.
Компонента DbInterface:
| // Структура таблицы TTableInfo = record // Атрибуты sTableAttr : TStrings; { sTableName - имя таблицы } { sTableCaption - наименование } { sTableDescr - описание } sFieldsL : TList; // Связанные DataSet и DataSource ... sQuery : TQuery; sQrDataSource : TDataSource; end; |
Обратим внимание на список sFieldsL, содержащий список ссылок на структуры полей. Упрощенный вид структуры поля имеет вид
| // Структура поля TFieldInfo = record // Атрибуты sFieldAttr : TStrings; { sFieldName - Имя поля } { sFieldCaption - Наименование } { sFieldDescr - Описание } sFieldType : TFieldType; sFieldSize : Integer; sFieldMBytes : Integer; end; |
Компонент TArmInterface: В данном случае производится считывание из системных таблиц информации о атрибутах приложения, применяемых для формирования его Главного меню. Эти атрибуты служат исходной информацией для структур TFbSUObject, входящих в компоненту TArmInterface. Поговорим о них чуть подробнее, хотя полный смысл будет ясен немного позже при рассмотрении более или менее функционального программного кода.
Асинхронный режим чтения из Com-порта
| Вступление |
Порядок запуска и работы "службы" (назовем все описываемое ниже так) Com-портов состоит из нескольких достаточно хорошо описанных шагов ( ):
| Чтение из Com-порта. |
Судя по контексту справки, касающейся функции CreateFile, для "отлова" момента поступления данных в Com-порт следует использовать функцию WaitCommEvent. Предварительно установив маску SetCommMask на то событие, которое хотелось бы отследить. Нужное событие наступает - вызываем функцию ReadFile для чтения поступающих данных.
Казалось бы все в порядке, но... Вызов функции WaitCommEvent насмерть тормозит приложение, пока какие-либо данные не поступят в Com-порт.
Можно конечно, просто взять и запустить в непрерывном цикле ReadFile, однако приложение хотя и будет как-то шевелиться, но это шевеление скорее всего будет напоминать предсмертные судороги.
Как выход из ситуации многие предлагают использовать потоки (thread), забывая при этом описать как это делать :)
Итак потоки.
В модуле Classes для потоков определен специальный класс TThread. Для создания потоков специалисты рекомендуют использовать именно его, а не создавать потоки используя BeginThread и EndThread, т.к. библиотека VCL не является защищенной для потоков в такой реализации. Следуя советам экспертов, для организации контроля поступающих данных в Com-порт и будем использовать готовый класс TThread.
В раздел interface определим тип переменных этого класса, переопределив только один метод класса - Execute, ну и дополнительно объявим свой метод, который и займется опросом Com-порта.
| Type //определим тип TComThread - наследника класса TThread TCommThread = class(TThread) private //процедура, занимающаяся опросом порта Procedure QueryPort; protected //переопределим метод запуска потока Procedure Execute; override; end; |
Далее в разделе глобальных переменных определим поток-переменную полученного выше типа CommThread:TCommThread; //наш поток, в котором будет работать процедура опроса порта Затем в разделе implementation начинаем ваять.
ВНИМАНИЕ!!!
К этому времени порт уже должен быть инициализирован функцией CreateFile.
| Procedure StartComThread; //инициализация нашего потока Begin {StartComThread} //пытаемся инициализировать поток CommThread:=TCommThread.Create(False); // проверяем получилось или нет If CommThread = Nil Then Begin {Nil} //ошибка, все выключаем и выходим SysErrorMessage(GetLastError); fmMain.btnStop.Click; Exit; End; {Nil} End; {StartComThread} |
| Procedure TCommThread.Execute; Begin {Execute} Repeat QueryPort;//процедура опроса порта будет производиться пока поток не будет прекращен Until Terminated; End; {Execute} |
| Procedure TCommThread.QueryPort; Var MyBuff:Array[0..1023] Of Char;//буфер для чтения данных ByteReaded:Integer; //количество считанных байт Str:String; //вспомогательная строка Status:DWord; //статус устройства (модема) Begin {QueryPort} //получим статус COM-порта устройства (модема) If Not GetCommModemStatus(hPort,Status) Then Begin {ошибка при получении статуса модема} //ошибка, все выключаем и выходим SysErrorMessage(GetLastError); fmMain.btnStop.Click; Exit; End; {ошибка при получении статуса модема} //Обработаем статус устройства (модема) и будем включать(выключать) лампочки //готовность устройства (модема) получать данные fmMain.imgCTSOn.Visible:=((Status AND MS_CTS_ON)=MS_CTS_ON); //готовность устройства (модема) к сеансу связи fmMain.imgDSROn.Visible:=((Status AND MS_DSR_ON)=MS_DSR_ON); //принимаются данные с линии сигнала fmMain.imgRLSDOn.Visible:=((Status AND MS_RLSD_ON)=MS_RLSD_ON); //входящий звонок fmMain.imgRingOn.Visible:=((Status AND MS_RING_ON)=MS_RING_ON); //читаем буфер из Com-порта FillChar(MyBuff,SizeOf(MyBuff),#0); If Not ReadFile(hPort,MyBuff,SizeOf(MyBuff),ByteReaded,Nil) Then Begin {ошибка при чтении данных} //ошибка, все закрываем и уходим SysErrorMessage(GetLastError); fmMain.btnStop.Click; Exit; End; {ошибка при чтении данных} //данные пришли If ByteReaded>0 Then Begin {ByteReaded>0} //посчитаем общее количество прочитанных байтов ReciveBytes:=ReciveBytes+ByteReaded; //преобразуем массив в строку Str:=String(MyBuff); //отправим строку на просмотр fmMain.Memo1.Text:=fmMain.Memo1.Text+ Str; //покажем количество считанных байтов fmMain.lbRecv.Caption:='recv: '+IntToStr(ReciveBytes)+' bytes...'; End; {ByteReaded>0} End; {QueryPort} |
На этом по поводу использования потоков для считывания данных из Com-порта, пожалуй, все.
| Прилагающийся пример |
В примере используется самое доступное устройство для пользователей интернет - модем (на Com-порту). В качестве "примочек" я использовал лампочки, которые включаются (или выключаются) при изменении статуса модема. Можно было прикрутить лампочки-детекторы входящих-выходящих сигналов, но вместо них используются счетчики байтов.
Реализация кода включения-выключения не самая лучшая: можно было бы использовать TImageList для хранения изображений лампочек. Но почему-то ??? (кто знает почему - напишите) использование ImageList.GetBitmap при наличии запущенного потока "подвешивает" приложение насмерть. Причем это происходит под Windows'98, если тоже самое делать под Windows'95, то все в порядке.
Для проверки работоспособности примера попробуйте понабирать AT-команды
Да, еще. Проект написан под Delphi3, при использовании Delphi более свежих версий возможны ошибки "несовпадения типов".
В этом случае поменяйте типы "ошибочных" переменных с Integer на Cardinal.
Скачать проект — (17K)
архив обновлен
Другие небольшие статьи,
примеры и программы можете найти на
Смотрите также :
Атрибуты АРМ
Каждое рабочее место должно иметь свой набор меню, поэтому необходим механизм создания структуры меню. Чтобы решить эту задачу, поступают следующим образом. В системной базе данных хранится ряд списков, в которых содержатся описания атрибутов, используемых для конструирования рабочих мест, т.е. меню приложения. В этом подходе реализация меню отождествляется с реализацией набора функций или же рабочего места в целом, молчаливо предполагая, что имеется некий банк функций, откуда их можно выбирать для выполнения конкретных задач. Такой банк обязан быть, и он будет определять товарную ценность платформы. Как он создается мы рассмотрим в свое время. Итак, перечислим наши атрибуты для конструирования АРМ.АРМ, т.е. автоматизированное рабочее место. Этот атрибут носит смысл вывески на фасаде здания, т.к. попросту используется для обозначения рабочего места. В частности, наименование АРМ выводится в заголовки экранных форм.
Окно. Может быть использовано как самостоятельное окно Windows, и в этом случае включение такого окна в меню означает возможность запуска конкретной, программно-реализованной формы. Другое назначение этого атрибута – служить верхним уровнем меню, содержащим список подменю, предназначенных для решения ряда схожих задач, образующих в совокупности требуемый режим работы АРМ Например, в верхнем пункте меню Прием звонка (режим работы) могут быть подменю или подпункты (содержание этого режима): Определение номера телефона, Карточка клиента, История обращений, Запись на очную консультацию.
Меню, точнее, пункт меню, кроме верхнего уровня, который может быть включен в любое место системы меню. Выбор пункта меню приводит либо к раскрытию вложенных пунктов меню, либо к запуску прикрепленной функции. В последнем случае должна обеспечиваться возможность адаптации действий по этому пункту меню к решаемой задаче, т.е. возможность выполнять не только одну единственную функцию, а также их совокупность. Например, если пользователь входит в режим Просмотр очереди на прием, то в некоторых случаях может потребоваться запрос пароля, или же какой-либо расчет. Поэтому прикрепление к меню функций осуществляется через так называемые алгоритмы.
Алгоритм представляет собой атрибут, содержащий список для хранения последовательности функций, которые необходимо выполнить при выборе пункта меню, к которому он прикреплен. Функции алгоритма выполняются строго в той последовательности, как они следуют в его списке. Если в алгоритме нет ни одной функции, то пункт меню, к которому он прикреплен, становится невыполнимым и возникает исключение.
Функция – это последний уровень в иерархии системы управления функциональностью платформы. Она обязательно содержит указатель на программный компонент - форму, процедуру или функцию на языке Object Pascal. Все перечисленные атрибуты хранятся в памяти в специальных схожих по типу структурах. Например, для хранения реквизитов АРМ используется структура
| // Структура АРМ TArm = record sTopInfo : TTopInfo; sOknoPtrL : TList; end; где TTopInfo – представляет собой структуру // Структура универсальной шапки TTopInfo = packed record sFbSUType : TFbSUType; // Тип структуры sID : TFbMedID; // Идентификатор sCaption : TFbMedName; // Наименование sDescr : TFbMedDesc; // Описание end; |
Данная шапка используется во всех структурах, поэтому в ней есть специальное поле sFbSUType, определяющее тип структуры. Тип структуры - перечислимый тип:
| // Тип структуры объекта управления TFbSUType = (apArmType, apOknoType, apMItemType, apAlgorType, apFuncType, apChannelBox, apNoneType); |
Вот теперь можно раскрыть вид структуры TFbSUObject, входящей в компоненту TArmInterface. Она представляет собой вариантную запись:
| // Обобщенная структура объекта управления TFbSUObject = packed record FbSUType : TFbSUType; case TFbSUType of apArmType : (Arm : pTArm); apOknoType : (Okno : pTOkno); apMItemType : (MItem : pTMItem); apAlgorType : (Algor : pTAlgor); apFuncType : (Func : pTFunc); apChannelBox : (); apNoneType : (); end; |
В этой структуре pTArm, pTOkno, pTMItem и т.д. – ссылки на соответствующие структуры TArm, TOkno, TMItem и т.д.
Компонента TArmInterface содержит набор функций для работы с приведенными атрибутами. Две из них, - для создания и удаления нового атрибута типа TFbSUObject, приведены выше.
Итак, окна, меню, алгоритмы и функции – суть элементы, позволяющие конструировать рабочее место. Атрибут, именуемый функцией, имеет особенность, заключающуюся в том, что его структура содержит поле sFormName, в которое записывается имя прикрепленной формы, запускаемая при активизации структуры, т.е. в момент выборки функции из списка алгоритмов:
| // Структура функции TFunc = record sTopInfo : TTopInfo; sFormName : TFbMedFormName; sAddressPtr: Pointer; end; |
То же самое относится к окну, имеющему программную реализацию в виде формы. В отличие от функции, структура окна может не содержать ссылки на форму, тогда она начинает играть роль пункта меню верхнего уровня.
Настройщик, главная после программиста фигура, непосредственно занимающаяся созданием функционально законченных решений, создает столько АРМ, сколько ему нужно иметь различных рабочих мест, снабжая каждое из них наименованием и комментарием, смысл которых соответствует предметной области. Фактически, при этом создаются структуры TArm. Настройщик создает и все необходимые структуры других типов, а также редактирует реквизиты структур функций, чтобы они полностью соответствовали области применения. Затем он формирует дерево управления, в каждый узел которого добавляет один из описанных выше атрибутов, соблюдая принятые соглашения. Это дерево сохраняется либо в системной базе данных, либо в локальных файлах конфигурации. При запуске приложения из дерева управления выбирается нужный корневой узел, т.е. АРМ. Таким образом, корневые узлы дерева управления содержат ссылки на АРМ. Затем специальная система запуска формирует главное меню системы выбранного АРМ, которое и определяет его облик.
Тот, кто дочитал до этого места, вероятно устал от обилия новых понятий и уже пришел к мысли, что описываемая конструкция – одна из многих возможных. Так оно и есть. Согласитесь, - не всегда хочется углубляться в детали программной конструкции, когда непонятна конечная цель, - ведь идея уже изложена. Реализация идеи – личное дело каждого архитектора программы. А посему время от времени будем переводить наше изложение в практическую плоскость.
Начнем мы с последовательности действий настройщика, когда он готовит поставляемый продукт для конкретной задачи заказчика. Затем мы дадим описание ключевых программных решений, так как к этому времени у читателя возникнет ряд каверзных вопросов. Получать ответы на них уже будет не так скучно.
| й Парунов, дата публикации 06 февраля 2003г. |
Стандартные потоки, широко применяющиеся в Delphi, резко упрощают повседневную работу с потоковыми данными. Но и у них есть недостаток. Дело в том, что в VCL потоки, и, главное, их базовый класс TStream, реализованы "в лоб": без всяких хитростей данные немедленно препровождаются по назначению (например, в файл). И такие операции занимают весьма значительное время (многие сотни машинных команд). Хорошо, если надо работать с "крупными" данными (килобайт и выше) - а если данные небольшие и разнообразные, замедление достигает 100 и более раз (на типе Char).
Стандартный способ ускорения подобных операций - работа с массивами элементов, вводя-выводя их в/из потока сразу. Но, во-первых, это значительно сложнее поэлементных операций, а во-вторых, если элементы имеют непостоянную длину, становится ещё сложнее. Делая небольшое отступление, замечу, что стандартная библиотека потокового ввода-вывода в большинстве реализаций C++ сделана не так - там потоки могут сами буферизовать передаваемые данные. Не понимаю, почему в Borland решили обойтись без этого. Единственное приходящее в голову объяснение - они твёрдо рассчитывали на "крупный" и "средний" обмен данными, который оптимально производить как раз без буферизации. Действительно, если посмотреть на C++ - сразу кружится голова от количества команд, необходимых для обслуживания буфера. Связано это с тем, что потоки могут попеременно читаться и писаться, а кроме того, одновременно использоваться многими потоками кода.
Ввиду этих проблем мной были написаны сравнительно простые буферные классы (работают на Delphi версий 4-5, должны работать и на последующих, а вот 3 версия уже не поддерживает перегрузку методов - в принципе, переписать и тут несложно), позволяющие производить буферизованный обмен с любыми потоками. В целях максимального ускорения работы классы эти, во-первых, не "thread-safe", а во-вторых, это два разных класса - для записи и для чтения - унаследованных от одного базового (кроме TObject, разумеется). Классы "пристёгиваются" к потоку (кстати, в C++ это делается практически так же) - и пользуются ими только для "крупного" обмена, осуществляя "мелкий" самостоятельно со своим буфером.
| ByteArray = packed array of Byte; psnAbstractStreamBuffer = class { Абстрактный предок классов для БЫСТРОЙ (буферизованно: вся цепочка до API-функций задействуется только при переполнении буфера, что даёт ускорение на порядок для данных длиной несколько байт) и УДОБНОЙ (перегруженные методы для разных типов данных позволяют не задавать их размер, хотя можно и так) бинарной работы с потоками заданной структуры. Принцип действия прост: накопление данных в буфере и сброс в поток - у буфера записи; чтение из потока и раздача данных из буфера - у буфера чтения. О позиции потока буфер не заботится - просто пишет или читает в текущей. А иначе будет монстр. Опасно что-то делать с потоком (хотя кому это надо?), когда к нему присоединён буфер, ведь буфер может переписать поток, прочитать устаревшие данные или сделать это не там, где надо. Перед подобными операциями сбрасывйте буфер методом Flush (при смене присоединённого потока (свойство Stream) и разрушении буфера это делается автоматически). Это касается и попеременной работы буферов чтения и записи с одним потоком... хотя зачем тогда буфер - чтобы постоянно его сбрасывать и устанавливать позицию потока? При ошибках чтения и записи возникают стандартные VCL-исключения EReadError и EWriteError.} private FStream: TStream; {присоединённый поток} FSize: Cardinal; {размер буфера} FBuffer, {буфер} FBufferEnd: PChar; {конец буфера (сразу за последним байтом) - понятно, что вместе с FSize и FBuffer избыточно, но это повысит скорость и упростит код} procedure SetStream(const Value: TStream); protected FCurrPos: PChar; {текущая позиция в буфере} property Size: Cardinal read FSize; property Buffer: PChar read FBuffer; property BufferEnd: PChar read FBufferEnd; constructor Create(const Stream: TStream; const Size: Cardinal); public property Stream: TStream read FStream write SetStream; {<> Nil !!!} procedure Flush; virtual; abstract; {сброс} destructor Destroy; override; {Stream разрушайте сами, если надо, ПОСЛЕ разрушения буфера} end; psnStreamWriter = class(psnAbstractStreamBuffer) public constructor Create( const Stream: TStream; {присоединённый поток, меняется свойством Stream} const Size: Cardinal = 1024 {размер буфера} ); procedure Flush; override; procedure WriteBuffer(const Data; const Count: Cardinal); {Этот метод не перегружен с Write, так как Delphi (4-5, во всяком случае) плохо выносит перегруженные методы, когда один из них имеет бестиповые параметры: Code Explorer сходит с ума, а Code Completion вообще хулиганит - самовольно добавляет раздел Private и дублирует объявление метода (без overload!!!) там, а потом ругается: мол, первый метод не был объявлен как overload).} procedure Write(const Data: Byte ); overload; procedure Write(const Data: Word ); overload; procedure Write(const Data: LongWord ); overload; procedure Write(const Data: Integer ); overload; procedure Write(const Data: Single ); overload; procedure Write(const Data: Double ); overload; procedure Write(const Data: Extended ); overload; procedure Write(const Data: String ); overload; procedure Write(const Data: ByteArray); overload; end; psnStreamReader = class(psnAbstractStreamBuffer) public constructor Create( const Stream: TStream; {присоединённый поток, меняется свойством Stream} const Size: Cardinal = 1024 {размер буфера} ); procedure Flush; override; procedure ReadBuffer(out Data; const Count: Cardinal); procedure Read(out Data: Byte ); overload; procedure Read(out Data: Word ); overload; procedure Read(out Data: LongWord ); overload; procedure Read(out Data: Integer ); overload; procedure Read(out Data: Single ); overload; procedure Read(out Data: Double ); overload; procedure Read(out Data: Extended ); overload; procedure Read(out Data: String ); overload; procedure Read(out Data: ByteArray); overload; end; |
Их методы WriteBuffer и ReadBuffer работают аналогично одноименным методам класса TStream, то есть они генерируют стандартные VCL-исключения EWriteError и EReadError при невозможности осуществления операции. Причина этого в том, что, в конце концов, вы должны знать формат своего файла, а не я :). Кроме того, если кто не знает, исключения ускоряют работу по сравнению с постоянной проверкой результата (если секция try...finally или try...except содержит цикл, а не наоборот).
EWriteError может возникнуть много позже того, как в буферный класс поступят первые "не вмещающиеся" данные (но до того, как будет разорвана связь буферного класса и потока!) - ведь они буферизуются. В большинстве случаев это не критично: если в поток не удалось записать, можно "тушить свет" - это серьёзная ошибка, и поток к дальнейшему употреблению всё равно непригоден.
В силу того, что "мелкий" обмен с потоками часто производится типизированно - например, чтение строк или чисел с плавающей точкой - классы дополнены перегруженными методами Write и Read для распространённых типов, позволяющими не раздувать исходный (и машинный) код, постоянно указывая размеры передаваемых данных. Эти методы настолько просты, что расширение их набора не представляет проблем - фактически они просто транслируются в вызовы WriteBuffer и ReadBuffer.
В заключение остаётся предупредить, что во избежание ошибок прежде, чем что-то делать с потоком (позицию сменить, прочитать/записать что-то помимо данного буферного класса), необходимо сбросить буфер методом Flush.
Сергей Парунов
Скачать (3 K)
Часть 1. MapX - библиотека разработчика приложений. Немного теории.
Доброе время суток, уважаемые коллеги. Этой статьей я открываю (или продолжаю) цикл статей посвященный использованию картографии в проектах Delphi. Предыдущие статьи касались в основном использования интегрированной картографии MapInfo, данная статья будет направлена на изучения ActiveX компонента MapX предназначенного для встраивания в свои приложения элементов картографии.
| Итак, что такое MapX.: |
MapX - это картографический ActiveX компонент, который можно использовать в языках программирования Visual Basic, Delphi, Visual C++, PowerBuilder и др. Используя карты, Вы можете отображать информацию в виде, легко понятном каждому. Карты более информативны, чем диаграммы и графики, и их интерпретация более наглядная и быстрая по сравнению с таблицами. MapX имеет обширный набор функций и позволяет разработчикам использовать в своих программах средства анализа и управления пространственными данными. МарХ основан на тех же картографических технологиях, которые используются в других продуктах MapInfo, таких как MapInfo Professional и Microsoft Map.
| Обзор основных возможностей : |
Вот в принципе возможности MapX : В данной статье речь будет идти о MapX версии 5.0 так как на текущий момент времени оная присутствовала у меня в наличии.
Часть 1 - Вызов MapInfo и встраивание его в свою программу (Основы интегрированной картографии)
Доброе время суток !
Данной статьей я начинаю цикл статей посвященных возможностям интегрированной картографии MapInfo и возможности встраивания геоинформационной системы в вашу программу. Примечания : Все примеры распространяются свободно и разработаны в обучающих целях на Delphi 6. Всю информацию по работе смотрите в прилагаемых исходных кодах.
Итак начнем.
Часть 1.
Давайте сделаем базовый проект, обеспечивающий динамическую подгрузку пакета. На самом деле это достаточно тривиально, но нам необходимоЗавершив эти "магические пассы", добавляем следующее: в секцию private вносим переменную FPackageHandle типа THandle. Она будет хранить дескриптор пакета. Туда же добавляем процедуру LoadPluginPackage, которая будет непосредственно выполнять загрузку пакета plugin.bpl.
Вот текст этой процедуры procedure TForm1.LoadPluginPackage; var FileName: TFileName; Begin // предполагаем, что пакет хранится в том же каталоге, что и исполняемое приложение FileName := ExtractFilePath(Application.ExeName); FileName := FileName + 'plugin.bpl'; // Загружаем пакет FPackageHandle := LoadPackage(FileName); if FPackageHandle = 0 then RaiseLastWin32Error() // пакет не загружен, выбрасываем исключение else MessageBox(Handle, 'Пакет plugin загружен', 'Информация', MB_APPLMODAL+MB_ICONINFORMATION+MB_OK); end; Теперь сделаем собственно пакет . В него поместим две формы, одну из которых сделаем дочерней (MDIChild), а на другую положим две кнопки (Ok и Cancel).
Далее организуем в главной форме загрузку пакета и вызов из него форм. Для этого на OnShow делаем вызов LoadPluginPackage и добавляем actions в ActionList:
Для дочерней формы procedure TForm1.aOpenExecute(Sender: TObject); var frmClass: TFormClass; frm: TForm; begin frmClass := TFormClass(GetClass('TfrmChild')); // получаем класс дочернего окна if not Assigned(frmClass) then begin MessageBox(Handle, PChar(Format('Не найден класс %s', ['TfrmDialogFrom'])), 'Ошибка', MB_APPLMODAL+MB_ICONERROR+MB_OK); Exit; end; frm := frmClass.Create(Self); // создаем дочернее окно end;
Для диалога procedure TForm1.aOpenDialogExecute(Sender: TObject); var frmClass: TFormClass; begin frmClass := TFormClass(GetClass('TfrmDialogFrom')); // получаем класс диалогового окна if not Assigned(frmClass) then begin MessageBox(Handle, PChar(Format('Не найден класс %s', ['TfrmDialogFrom'])), 'Ошибка', MB_APPLMODAL+MB_ICONERROR+MB_OK); Exit; end; // создаем и показываем окно диалога with frmClass.Create(Self) do try case ShowModal of mrOk: MessageDlg('Выбрано Ok!', mtInformation, [mbOk], 0); mrCancel: MessageDlg('Выбрано Cancel!', mtInformation, [mbOk], 0); else MessageDlg('Выбрано хрен знает что!', mtInformation, [mbOk], 0); end; finally Free(); end; end; Плюс ко всему добавляем обработчик OnUpdate на все action'ы для обеспеченя корректного вызова procedure TForm1.aOpenUpdate(Sender: TObject); begin aOpen.Enabled := FPackageHandle > 0; aOpenDialog.Enabled := FPackageHandle > 0; end; Полный исходный код находится в архиве (каталог Step1)
Часть 2. Доступ к объектам пакета.
Попытаемся наладить связь между главной формой и пакетом. То есть, мы ставим себе задачу вызова некоторой (или некоторых) функции/процедур формы из пакета при условии того, что мы не знаем действительный тип этой формы и всего набора поддерживаемых ею функций и процедур. Для осуществления этого воспользуемся технологией COM. Точнее той ее части, которая поддерживается Delphi на уровне языка.Для того, чтобы новичкам было все ясно, следует немного углубиться в понятие интерфейса. Я полагаю, что вы знакомы с понятием виртуальной таблицы методов (VMT). Именно она является источником и тремя составными частями ООП . Для поддержки COM в Delphi был введен новый, особый тип interface, который позволяет "поименовать" куски виртуальной таблицы методов. Способ этого именования достаточно уникален - 16-байтовое число , которое присваивается каждому такому куску. Есть мнение, что оно статистически уникально . Синтаксис данного типа следующий type IMyInitialize = interface ['{7D501741-B419-11D5-915B-ED714AED3037}'] // то самое 16-битное число в строковом // представлении. Получается // в Delphi нажатием клавиш Ctrl+g. procedure InitializeForm(const ACaption: String); // а это процедура интерфейса. end; Помимо прочего компоненты Delphi содержат метод, позволяющий получать этот кусок виртуальной таблицы. Причем этих методов два.
Теперь давайте прикрутим к нашей системе интерфейсы и покажем, как с ними работать. Для этого создаем новый модуль (он достаточно короткий, и я здесь привожу его полностью) unit CommonInterfaces; interface type IMyInitialize = interface ['{7D501741-B419-11D5-915B-ED714AED3037}'] procedure InitializeForm(const ACaption: String); end; IMyHello = interface ['{7D501742-B419-11D5-915B-ED714AED3037}'] function ShowHello(AText: String): String; end; implementation end. Далее, внесем изменения в наш пакет, учитывающий поддержку интерфейсов 1. для дочерней формы: type TfrmChild = class(TForm, IMyInitialize, IMyHello) // так наследуются интерфейсы Private { описание методов IMyInitialize } procedure InitializeForm(const ACaption: String); { описание методов IMyHello } function ShowHello(AText: String): String; end; Что мы тут сделали? Мы сказали, что TfrmChild является наследником TForm, но помимо методов TForm VMT класа TfrmChild содержит еще два цельных куска, один из которых идентичен VMT IMyInitialize, а второй VMT IMyHello. 2. для диалоговой формы: type TfrmDialogFrom = class(TForm, IMyInitialize) BitBtn1: TBitBtn; BitBtn2: TBitBtn; Label1: TLabel; private { описание методов IMyInitialize } procedure InitializeForm(const ACaption: String); end; Реализация этих методов проста, ее можно смотреть в архиве (Step2).
Соответственно (для вызова этих методов), немного корректируем главную форму… procedure TForm1.aOpenExecute(Sender: TObject); var frmClass: TFormClass; frm: TForm; MyInitialize: IMyInitialize; begin frmClass := TFormClass(GetClass('TfrmChild')); if not Assigned(frmClass) then begin MessageBox(Handle, PChar(Format(' Не найден класс %s', ['TfrmDialogFrom'])), 'Ошибка', MB_APPLMODAL+MB_ICONERROR+MB_OK); exit; end; frm := frmClass.Create(Self); // производим вызов метода интерфейса if frm.GetInterface(IMyInitialize, MyInitialize) then begin // интерфейс поддерживается формой, можно вызывать его методы MyInitialize.InitializeForm(Format('Дочернее окно ? %d', [Tag])); Tag := Tag + 1; end else raise Exception.CreateFmt('Интерфейс %s не поддерживается классом %s', ['ImyInitialize', frm.GetClassName]); end; procedure TForm1.aOpenDialogExecute(Sender: TObject); var frmClass: TFormClass; MyInitialize: IMyInitialize; begin frmClass := TFormClass(GetClass('TfrmDialogFrom')); if not Assigned(frmClass) then begin MessageBox(Handle, PChar(Format('Не найден класс %s', ['TfrmDialogFrom'])), 'Внимание!', MB_APPLMODAL+MB_ICONERROR+MB_OK); Exit; end; with frmClass.Create(Self) do try if GetInterface(IMyInitialize, MyInitialize) then begin // Интерфейс поддерживается фомой, вызываем его метод MyInitialize.InitializeForm(' Диалог'); end else raise Exception.CreateFmt('Интерфейс %s не поддерживается классом %s', ['ImyInitialize', frm.GetClassName]); case ShowModal of mrOk: MessageDlg('Ok!', mtInformation, [mbOk], 0); mrCancel: MessageDlg('Cancel!', mtInformation, [mbOk], 0); else MessageDlg('Неизвестная распальцовка!', mtInformation, [mbOk], 0); end; finally Free(); end; end; Полностью весь проект смотрите в архиве (Step2.zip).
Теперь что мы имеем.
Часть 2. Работа с примитивами и изображениями.
Доброе время суток, уважаемые коллеги. В данной статье мы разберем вывод графических примитивов и вывод изображений. GDI+ предоставляет программисту огромный выбор методов для вывода графики, в данной статье мы рассмотрим вывод примитивов с заливкой и без, вывод примитивов с своим стилем линии, использование групп (путей) для группировки примитивов и вывода их на экран, также мы рассмотрим операции по загрузке и выводу изображений, создание на основе изображения - мини-просмотра (Thumbnail), вывода изображения в область (растягивание), вывод изображения в параллелограмм. В данной статье я не буду специально рассматривать трансформацию изображений и примитивов, а так же заливку примитивов различными градиентами и изображениями, так как в первой части данного цикла статей я дал простые примеры по данным вопросам, а применить их к изображению иль к примитивам не составляет особого труда.
Итак, что в данной части мы получим -
Итак, сверху - вниз :
| procedure TForm1.PaintBox1Paint(Sender: TObject); Const dash : array[0..3] of single = (1, 1, 5, 4); Grani : array[0..2] of TPoint = ((x: 620; y: 180), // Верхняя грань (x: 560; y: 200), // Правая грань (x: 600; y: 260)); // Нижяя грань var R : TRect; Pen : TGPPen; // Кисть SolidBrush : TGPSolidBrush; // Заливка непрерывным цветом path : TGPGraphicsPath; // Пути Image, pThumbnail: TGPImage; // Рисунок begin graphicsGDIPlus := TGPGraphics.Create(PaintBox1.Canvas.Handle); // Рисование примитивов без заливки pen:= TGPPen.Create(MakeColor(255, 0, 0, 0), 1); R.X := 0; R.Y := 0; R.Width := 50; R.Height := 50; graphicsGDIPlus.DrawRectangle(Pen,R); graphicsGDIPlus.DrawLine(Pen,R.X,R.Y,R.X+R.Width,R.Y+R.Height); pen.Free; // Рисование примитивов без заливки c толщиной линии 5 pen:= TGPPen.Create(MakeColor(255, 0, 0, 0), 5); R.X := 60; R.Y := 0; R.Width := 50; R.Height := 50; graphicsGDIPlus.DrawRectangle(Pen,R); graphicsGDIPlus.DrawLine(Pen,R.X,R.Y,R.X+R.Width,R.Y+R.Height); pen.Free; // Рисование примитивов без заливки c толщиной линии 5 и собственным стилем Dash pen:= TGPPen.Create(MakeColor(255, 0, 0, 0), 5); Pen.SetDashPattern(@dash, 4); R.X := 120; R.Y := 0; R.Width := 50; R.Height := 50; graphicsGDIPlus.DrawRectangle(Pen,R); graphicsGDIPlus.DrawLine(Pen,R.X,R.Y,R.X+R.Width,R.Y+R.Height); pen.Free; // Использование графических путей path := TGPGraphicsPath.Create; pen:= TGPPen.Create(MakeColor(255, 0, 0, 0), 1); path.Reset; R.X := 180 ; R.Y := 0; R.Width := 50; R.Height := 50; path.StartFigure(); path.AddArc(R, 0.0, -180.0); path.AddLine(R.X, R.Y+25, R.X+25, R.Y+R.Height); path.AddLine(R.X+25, R.Y+R.Height,R.X+R.Width, R.Y+25); path.CloseFigure(); graphicsGDIPlus.DrawPath(pen, path); Pen.Free; // Рисование примитивов с заливкой непрерывным цветом // Создаем объект для непрерывной заливки SolidBrush := TGPSolidBrush.Create(MakeColor(255, 255, 255, 0)); R.X := 0 ; R.Y := 60; R.Width := 50; R.Height := 50; graphicsGDIPlus.FillRectangle(SolidBrush,R); SolidBrush.Free; SolidBrush := TGPSolidBrush.Create(MakeColor(255, 255, 255, 0)); R.X := 60 ; R.Y := 60; R.Width := 50; R.Height := 50; graphicsGDIPlus.FillEllipse(SolidBrush,R); SolidBrush.Free; // Использование графических путей path := TGPGraphicsPath.Create; SolidBrush := TGPSolidBrush.Create(MakeColor(255, 255, 255, 0)); path.Reset; R.X := 120 ; R.Y := 60; R.Width := 50; R.Height := 50; path.StartFigure(); path.AddArc(R, 0.0, -180.0); path.AddLine(R.X, R.Y+25, R.X+25, R.Y+R.Height); path.AddLine(R.X+25, R.Y+R.Height,R.X+R.Width, R.Y+25); path.CloseFigure(); graphicsGDIPlus.FillPath(SolidBrush, path); SolidBrush.Free; // РАБОТА С ИЗОБРАЖЕНИЕМ // Создаем Thumbnail (Мини просмотр) Image:= TGPImage.Create('FRUIT.JPG'); pThumbnail := Image.GetThumbnailImage(60, 48, nil, nil); graphicsGDIPlus.DrawImage(pThumbnail, 0, 120, pThumbnail.GetWidth, pThumbnail.GetHeight); pThumbnail.Free; pThumbnail := Image.GetThumbnailImage(20, 20, nil, nil); graphicsGDIPlus.DrawImage(pThumbnail, 70, 120, pThumbnail.GetWidth, pThumbnail.GetHeight); pThumbnail.Free; // Вывести изображение как есть graphicsGDIPlus.DrawImage(image, 0, 180); // Вывести изображение в область R := MakeRect(220, 180, 320, 200); graphicsGDIPlus.DrawImage(Image,R); // Вывести изображение в парралелограмм graphicsGDIPlus.DrawImage(Image, PPoint(@Grani), 3); Image.Free; graphicsGDIPlus.Free; end; |
Вот в принципе и все, еще раз повторюсь, ничего сложного в GDI+ нет, а огромное количество примеров по использованию от дадут вам совершенно новый механизм по выводу графики в Delphi. Данной статьей я хотел показать основы работы, привлечь внимание начинающих программистов к данной библиотеке
Скачать (219 K)
С уважением к коллегам, .
| Для данного материала нет комментариев. |
Часть 2. Создание собственных инструментов, строка состояния - вывод координат.
Доброе время суток, уважаемые коллеги. Этой статьей я продолжаю цикл изучения ActiveX компонента MapX предназначенного для встраивания в свои приложения элементов картографии. В данной статье мы научимся создавать собственные инструменты (tool), собственные (не предопределенные) указатели мыши для собственных инструментов, создадим статус строку с выводом координат. Итак, в прошлом проекте мы создали простое картографическое приложение, теперь мы хотим его приукрасить, это не сложно.
1. Для начала мы сделаем статусную строку где будем выводить координаты мыши преобразованные в координаты на карте.
Итак, в обработчик MouseOver пропишем следующий код, предварительно положив StatusBar на форму.
| procedure TForm1.MapXMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var ScreenX,ScreenY : Single; MX,MY : Double; begin //Конвертируем координаты экрана в координаты карты ScreenX := X; ScreenY := Y; MapX.ConvertCoord(ScreenX,ScreenY,MX,MY,miScreenToMap); StatusBar.Panels[0].Text := 'X:' + FloatToStr(MX) + ' Y:' + FloatToStr(MY); end; |
Итак что мы сделали - в обработчике мы вызвали метод ConvertCoord, который служит для конвертации координат карты в экранные и наоборот, в зависимости от параметра (miScreenToMap - экранные в картографические, miMapToScreen - картографические в экранные), при этом хочу обратить внимание я специально перевел экранные координаты в тип Single, т.к. процедура требует именно тип Single для экранных координат, ну а далее координаты выведем в строку состояния.
Согласитесь ничего сложного.
2. Все это конечно хорошо но внимательный читатель может задать вопрос а как преобразовывать координаты например в градусы , на что я отвечу к сожалению в MapX нет команд непосредственно изменяющих единицы измерения координат, так как MapX берет координаты непосредственно с карты, если вы хотите настроить вывод координат в градусах при определенной проекции карты вы должны, предварительно щелкнув правой клавишей на объекте Tmap, вызвать окно свойств и там загрузив слои, настроить проекцию.
3. После того как мы научились определять координаты на карте, рассмотрим вопрос создания собственных инструментов (что очень неудобно было в интегрированной картографии) в MapX делается очень просто - для этого существует команда CreateCustomTool;
Вот ее синтаксис :
| CreateCustomTool (ToolNumber, Type, Cursor, [ShiftCursor],[CtrlCursor], [InfoTips]) |
Небольшое отступление.
Если Вы создаете CustomTool типа "окружность" и в событии Tool_Used среды МарХ определяется SelectByRadius с величиной, передаваемой в событие, результаты получаются не такими, как если Вы выбираете объекты в Radius Select Tool. Метод SelectByRadius не будет точно выбирать, поскольку такой круг не учитывает проекцию карты. Выборки сделанные Radius Select Tool точно выбирают все объекты в заданной окружности.
| ToolNumber | Количество инструментов, используемое в дальнейшем. Это целое между 1 и 999 |
| Type | Тип описывает поведение инструмента. Берется значениеToolTypeConstants, Которое имеет следующие значения :ToolTypeConstants |
| Cursor | Курсор в случае когда инструмент создан в и курсор в CurrentTool окне карты. Значение выбирается из коллекции CursorConstants. Которая имеет вид :CursorConstants |
| ShiftCursor | Значение CursorConstants, указывающее, что курсордолжен появиться, пока нажата клавиша SHIFT. Heобязательный параметр. Если он пропущен, клавиша SHIFT недействует на курсор. |
| CtrlCursor | Значение CursorConstants, указывет, что курсордолжен появиться, пока нажата клавиша CTRL. Heобязательный параметр. Если он пропущен, клавиша CTRL недействует на курсор. |
Итак я создал 2 собственных инструмента в FormCreate - это инструмент стрелка (указатель) и инструмент окружность (круг).
Вот они :
| MapX.CreateCustomTool(ToolCustomArrow,miToolTypePoint,miDefaultCursor); MapX.CreateCustomTool(ToolCustomCircle,miToolTypeCircle, miDefaultCursor); |
| Const ToolCustomArrow = 1; ToolCustomCircle = 2; |
| MapX.MousePointer := miDefaultCursor; MapX.CurrentTool := miArrowTool; |
| MapX.MousePointer := miCustomCursor; MapX.MouseIcon := 'Icon2.ico'; MapX.CurrentTool := ToolCustomCircle; |
Ну и наконец в обработчике инструментов пользователя MapXToolUsed я прописал следующий демо-код.
| procedure TForm1.MapXToolUsed(Sender: TObject; ToolNum: Smallint; X1, Y1, X2, Y2, Distance: Double; Shift, Ctrl: WordBool; var EnableDefault: WordBool); begin IF ToolNum = ToolCustomArrow Then ShowMessage('Использован собственный инструмент - стрелка'); IF ToolNum = ToolCustomCircle Then ShowMessage('Использован собственный инструмент - Круг'); end; |
С уважением к коллегам,
.
Скачать проект: (11 K)
Можно несколько усложнить наш пример
Можно несколько усложнить наш пример и наглядно продемонстрировать новые преимущества данной методики. Давайте добавим на форму объект TListBox и изменим реализацию метода ShowHello из интерфейса IMyHello следующим образом function TfrmChild.ShowHello(AText: String): String; begin InputQuery('Вот что спросили', AText, Result); ListBox1.Items.Add('Вот что спросили:'); ListBox1.Items.Add(AText); ListBox1.Items.Add('Вот что ответили:'); ListBox1.Items.Add(Result); ListBox1.Items.Add(''); end; Идем к форме TfrmDialogFrom, добавляем туда большую кнопку, на OnClick которой пишем следующее: procedure TfrmDialogFrom.Button1Click(Sender: TObject); var MyHello: IMyHello; Result: String; begin if Assigned(Application.MainForm.ActiveMDIChild) and Application.MainForm.ActiveMDIChild.GetInterface(IMyHello, MyHello) then begin Result := MyHello.ShowHello('Где начало того конца, которым начинается начало?'); ShowMessage(Result); end; end; Если задуматься над этой процедурой, то станет ясно, что нам не важен тип активной дочерней формы и местоположение реализации этого типа (в главном приложении находится ее модуль, в том же пакете, что и TfrmDialogFrom, или где-нибудь еще). Мы просто обнаружили, что есть какая-то активная форма, спросили ее на предмет поддержки конкретного интерфейса и вызвали его метод.Полный исходный код этой части находится в архиве (каталог Step3)
Часть 3. Взаимодействие пакета с приложением
При разработке проекта довольно часто встречается ситуация, когда одна из форм (модулей данных, компонент или, наконец, просто объектов) обращается к методам второй формы, а та, в свою очередь, нуждается в вызове методов (или в доступе к свойствам) первой. Иногда эта ситуация вообще трудно разрешима (если оказываются необходимыми перекрестные ссылки в интерфейсных частях модулей — это недопустимо правилами языка) . Очень часто взаимодействие модулей проекта, форм и т.д. оказывается до такой степени перепутанным, что разобраться в этих хитросплетениях бывает тяжело (особенно если этот проект передается для дальнейшего сопровождения и доработки другому программисту). Часть таких проблем вполне может снять использование интерфейсов. Действительно, в предыдущей части для использования методов форм из пакета нам не потребовалось подключать модули, содержащие их реализацию. Что помешает использовать ту же технологию и в обратном направлении?Попробуем это реализовать. В модуль CommonInterfaces добавляем новый интерфейс ICallBackInterface = interface ['{7D501743-B419-11D5-915B-ED714AED3037}'] procedure Callback(Text: String); end; Добавляем этот интерфейс к главной форме приложения type TForm1 = class(TForm, ICallBackInterface) MainMenu: TMainMenu; … protected { ICallBackInterface } procedure Callback(Text: String); … end; var Form1: TForm1; implementation … procedure TForm1.Callback(Text: String); begin ShowMessage('Из главной формы с приветом "' + Text + '"'); end; … А теперь возвращаемся в пакет и пробуем вызвать метод Callback главной формы из пакета. В дочерней форме TfrmChild создаем TAction aQueryInMainForm, цепляем его в меню и создаем реализацию OnExecute procedure TfrmChild.aQueryInMainFormExecute(Sender: TObject); var CallBackInterface: ICallBackInterface; begin if Application.MainForm.GetInterface(ICallBackInterface, CallBackInterface) then CallBackInterface.Callback('Привет от дочерней формы ' + Caption); end; Теперь запускаем и проверяем, что все у нас работает как надо.
Часть 4. Некоторые нюансы
В связи с тем, что мы "разбиваем" виртуальную таблицу методов наших форм на "куски"-интерфейсы, возможны ситуации, когда несколько интерфейсов будут содержать методы с одинаковым названием. Способ обработки таких случаев известен программистам, работавшим с COM. Для тех, кому он неизвестен, я сейчас его продемонстрирую.Добавим еще один интерфейс в модуль CommonInterfaces и назавем его ICallbackInterface2. В интерфейсе опишем процедуру с названием, пересекающимся с ICallbackInterface: ICallbackInterface2 = interface ['{7D501744-B419-11D5-915B-ED714AED3037}'] procedure Callback(Text: String); end; Теперь введем этот интерфейс в главную форму: type TForm1 = class(TForm, ICallBackInterface, ICallbackInterface2) MainMenu: TMainMenu; File1: TMenuItem; … Чтобы компилятор правильно различал вызовы методов Callback от разных интерфейсов, секцию protected перепишем следующим образом: … protected // перенаправляем вызов через ICallBackInterface к процедуре Callback1 procedure ICallBackInterface.Callback = Callback1; // перенаправляем вызов через ICallBackInterface2 к процедуре Callback2 procedure ICallBackInterface2.Callback = Callback2; procedure Callback1(Text: String); procedure Callback2(Text: String); … end; … procedure TForm1.Callback1(Text: String); begin ShowMessage('Из главной формы 1 "' + Text + '"'); end; procedure TForm1.Callback2(Text: String); begin ShowMessage(' Из главной формы 2 "' + Text + '"'); end; И, наконец, в форме TfrmChild нашего пакета строим вызовы этих методов type TfrmChild = class(TForm, IMyInitialize, IMyHello) … aQueryInMainForm: TAction; aQueryInMainForm2: TAction; … procedure aQueryInMainFormExecute(Sender: TObject); procedure aQueryInMainForm2Execute(Sender: TObject); private … procedure TfrmChild.aQueryInMainFormExecute(Sender: TObject); var CallBackInterface: ICallBackInterface; begin if Application.MainForm.GetInterface(ICallBackInterface, CallBackInterface) then CallBackInterface.Callback('Привет от ' + Caption); end; procedure TfrmChild.aQueryInMainForm2Execute(Sender: TObject); var CallBackInterface: ICallBackInterface2; begin if Application.MainForm.GetInterface(ICallBackInterface2, CallBackInterface) then CallBackInterface.Callback('Привет от ' + Caption); end; … Запускаем и убеждаемся в том, что вызываются действительно нужные методы.
Полный исходный код этой части находится в архиве (каталог Step4).
Еще один нюанс, известный программистам COM. Ничто не запрещает вводить в интерфейсы обычные свойства Deplhi (для более простого моделирования). Ограничением, естественно, является только то, что интерфейс не может содержать полей-данных. В интерфейсы должны быть описаны только методы. Вот пример интерфейса содержащего свойства IMainForm = interface ['{765B2E71-B81C-11D5-9160-C43E6EC62937}'] function GetCaption: TCaption; procedure SetCaption(const Value: TCaption); function GetFont: TFont; procedure SetFont(conts Value: TFont); function GetSelf: TForm; property Caption: TCaption read GetCaption write SetCaption; property Font: TFont read GetFont write SetFont; property Self: TForm read GetSelf; end Естественно, при наследовании некоторым классом (скажем, какой-нибудь формой) этого интерфейса необходимо в него ввести реализацию методов GetCaption, SetCaption, GetFont, SetFont, GetSelf .
Ну и напоследок, интерфейсы можно наследовать так же, как и обычные классы. При чем это наследование может быть множественным (как в С++). Пример:
У нас был интерфейс ICallBackInterface: ICallBackInterface = interface ['{7D501743-B419-11D5-915B-ED714AED3037}'] procedure Callback(Text: String); end; Добавляем еще один интерфейс, расширяющий поведение ICallBackInterface ICallBackInterfaceEx = interface(ICallBackInterface) ['{7D501743-B419-11D5-915B-ED714AED3038}'] procedure CallbackEx(Text: String); end; , а в главной форме поменяем наследование TForm1 = class(TForm, ICallBackInterface, ICallbackInterfaceEx) Теперь после компиляции что мы получим?
Вызов Application.MainForm.GetInterface(ICallBackInterface, CallBackInterface) всегда будет возвращать ссылку на кусок виртуальной таблицы методов, содержащей процедуру Callback и только ее (то есть, действительно ссылку ICallBackInterface, хотя мы его явно не наследовали).
А вот вызов Application.MainForm.GetInterface(ICallBackInterfaceEx, CallBackInterface) будет возвращать ссылку на кусок виртуальной таблицы методов, содержащей как процедуру Callback, так и CallbackEx.
Часть 5. Агрегация
До сих пор для получения интерфейса объекта я использовал функцию GetInterface. Она прекрасно работает и удобна в использовании, но имеет существенные ограничения. Прежде всего, эта функция не виртуальная. То есть, вы не сможете переопределить ее поведение в классах-наследниках. А делает эта функция только одно - сканирует локальную VMT объекта на предмет получения требуемого куска VMT. Однако, начиная от TComponent, компоненты Delphi содержат функцию, делающую почти то же самое, но являющуюся виртуальной. Под "почти" я имею ввиду то, что эта функция вызывает GetInterface, но осуществляет еще дополнительные проверки и имеет немного другой формат вызова. Эта функция в последствии принимает участие в COM программировании и имеет наименование QueryInterface .Функция определяется так: function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; Функция возвращает HResult (целое число, содержащее код ошибки) для определения успешности или не успешности ее выполнения. Для преобразования этого значения в boolean (если нет необходимости анализировать непосредственно код ошибки и вас интересует лишь фактическое "да" или "нет") имеется дополнительная функция Succeeded. Любой вызов GetInterface из приведенных выше примеров можно заменить на примерно следующий: if Succeeded(QueryInterface(IMyHello, MyHello)) then … Однако есть одна маленькая неприятность - функция QueryInterface описана в секции protected класса TComponent. Это означает, что вы не можете ее вызвать нигде, кроме как внутри методов данного класса TComponent. То есть, строка Application.MainForm.QueryInterface(…) не будет компилироваться. Из этого есть два выхода. Первый заключается в получении ЛЮБОГО интерфейса объекта через вызов GetInterface и через него вызывать функцию QueryInterface. Для этих целей можно написать обобщенную процедуру, скажем так function QueryInterface(const AObject: TObject, const IID: TGUID; out Obj): HResult; begin if AObject.GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; Второй заключается в написании наследников всех (или почти всех) используемых базовых компонент, в которых эта функция перемещается в секцию public. Примерно вот так: type TInterfacedForm = class(TForm, IUnknown) public function QueryInterface(const IID: TGUID; out Obj): HResult; override; end; … implementation function TInterfacedForm .QueryInterface(const IID: TGUID; out Obj): HResult; begin Result := inherited QueryInterface(IID, Obj); end; end. Если при этом все необходимые компоненты проекта (в частности, главную форму приложения) наследовать от них, тогда в любой точке проекта можно будет построить следующий вызов. var MainForm: TInterfacedForm; begin if Application.MainForm is TInterfacedForm then begin MainForm := Application.MainForm is TInterfacedForm; if Succeeded(MainForm.QueryInterface(IMyHello, MyHello)) then … … end; end; Остается заметить, что этот модуль желательно оформить в виде отдельного пакета, установить его в системе и компилировать с ним как основное приложение, так и пакеты-плугины.
Теперь, после всего выше сказанного, нетрудно осуществить непосредственную агрегацию. Первое место, где она с успехом может быть применена - это приложения с использованием БД. Обычно в этом случае основное приложение имеет (помимо главной формы) один или несколько модулей данных (наследников TDataModule), содержащих коннект к БД и бизнес логику приложения. Чтобы явно подчеркнуть непосредственно агрегацию, сделаем главную форму не наследующей никакого интерфейса. Между тем, оказывается возможным (с помощью простой, но довольно обобщенной махинации) запрашивать требуемые дочерней форме интерфейсы и выполнять над ними работу. Исходный текст проекта см. в архиве (каталог Step5). Код проекта мал, упрощен насколько это возможно и вряд ли нуждается в особых комментариях.
Часть II - Реализация CallBack вызовов MapInfo и перехват в собственной программе.
Доброе время суток ! Краткое примечание
Немного об отзывах - хочу сообщить и повторить снова в данных циклах статей не будет информации об ActiveX компоненте MapX (о работе с ней, отзывы о ней и т.п.) по причине отсутствия у меня оной (может кто поделится J).
Часть II
| , часть I Вернуться к разделу | тели часто стали жаловаться клиенты на то, что их двигатели клинят. Руководству фирмы не что не оставалась делать, как объявить награду в 1000 долларов тому кто найдет и исправит причину заклинивания неудачного двигателя. Через час приходит обыкновенный ремонтник и одним ударом молотка исправляет деффект. Причем цену назначает так 1 доллар за удар молотка и 999 за место по которому нужно ударить. |
| Структура DCB |
Структура DCB определяет установку управления для последовательного порта ввода-вывода (нам она понадобится для разбора примера с программой управления весами ПетрВес)
Примечание : В местах где нельзя дать точный перевод будет дано определение на английском из MSDK и приблизительный его перевод
Описание в эквиваленте C
typedef struct _DCB { // dcb DWORD DCBlength; // Размер DCB DWORD BaudRate; // Скорость пересылки данных в бодах; // текущая скорость в бодах DWORD fBinary: 1; // binary mode, no EOF check // двоичный режим , не проверять конец // данных (по умолчанию значение = 1) DWORD fParity: 1; // Включить проверку четность (по умолчанию // значение = 1) DWORD fOutxCtsFlow:1; // CTS управление потоком выхода DWORD fOutxDsrFlow:1; // DSR управление потоком выхода DWORD fDtrControl:2; // DTR Тип управления потоком скорости // передачи данных DWORD fDsrSensitivity:1; // DSR sensitivity (чувствительность) DWORD fTXContinueOnXoff:1; // XOFF continues Tx (стоп-сигнал // продалжает выполнение) DWORD fOutX: 1; // XON/XOFF out flow control (СТАРТ- // СИГНАЛ / СТОП-СИГНАЛ для управления // выходящим потоком (по умолчанию // значение = 1) DWORD fInX: 1; // XON/XOFF in flow control (СТАРТ- // СИГНАЛ / СТОП-СИГНАЛ для управления // входящим потоком (по умолчанию // значение = 1) DWORD fErrorChar: 1; // enable error replacement (включить // проверку погрешностей по умолчанию=1) DWORD fNull: 1; // enable null stripping (отвергать // пустой поток данных (по умолчанию=1)) DWORD fRtsControl:2; // RTS управление потоком данных DWORD fAbortOnError:1; // abort reads/writes on error // (проверять операции чтения/записи // по умолчанию=1) DWORD fDummy2:17; // reserved ЗАРЕЗЕРВИРОВАНО WORD wReserved; // not currently used НЕ ДЛЯ // ИСПОЛЬЗОВАНИЯ WORD XonLim; // transmit XON threshold (порог // чувствительности старт-сигнала) WORD XoffLim; // transmit XOFF threshold (порог // чувствительности стоп-сигнала) BYTE ByteSize; // Бит в байте (обычно 8) BYTE Parity; // 0-4=no,odd,even,mark,space // (четность байта) BYTE StopBits; // 0,1,2 = 1, 1.5, 2 (стоповые биты) char XonChar; // Tx and Rx XON character (вид // старт сигнал в потоке) char XoffChar; // Tx and Rx XOFF character (вид // стоп сигнал в потоке) char ErrorChar; // error replacement character (какой // сигнал погрешности,его вид) char EofChar; // end of input character (сигнал // окончания потока) char EvtChar; // received event character РЕЗЕРВ WORD wReserved1; // reserved; do not use НЕ ДЛЯ // ИСПОЛЬЗОВАНИЯ } DCB;
Пример :
with Mode do Begin BaudRate := 9600; ByteSize := 8; Parity := NOPARITY; StopBits := ONESTOPBIT; // одиночный стоп-бит Flags := EV_RXCHAR + EV_EVENT2; End;
Параметры :
DCBlengthРазмер DCB структуры. BaudRateОпределяет скорость в бодах, в которых порт оперирует. Этот параметр может принимать фактическое значение скорости в бодах, или один из следующих стандартных индексов скорости в бодах: CBR_110 CBR_19200 CBR_300 CBR_38400 CBR_600 CBR_56000 CBR_1200 CBR_57600 CBR_2400 CBR_115200 CBR_4800 CBR_128000 CBR_9600 CBR_256000 CBR_14400 fBinaryОпределяет, допускается ли двоичный (бинарный) способ передачи данных. Win32 API не поддерживает недвоичные (небинарные) способы передачи данных в потоке порта, так что этот параметр должен быть всегда ИСТИНЕН. Попытка использовать ЛОЖЬ в этом параметре не будет работать.
Примечание :
Под Windows 3.1 небинарный способ передачи допускается,но для работы данного способа необходимо заполнит параметр EofChar который будет восприниматься конец данных. fParityОпределяет, допускается ли проверка четности. Если этот параметр ИСТИНЕН, проверка четности допускается fOutxCtsFlowCTS (clear-to-send) управление потоком выхода fOutxDsrFlowDSR (data-set-ready) управление потоком выхода fDtrControlDTR (data-terminal-ready) управление потоком выхода
Принимает следующие значения :
Отключает линию передачи дынных
Включает линию передачи дынных
Enables DTR handshaking. If handshaking is enabled, it is an error for the application to adjust the line by using the EscapeCommFunction function.
Допускает подтверждению связи передачи данных Если подтверждение связи допускается, это - погрешность для того чтобы регулировать(корректировать) линию связи, используя функцию EscapeCommFunction.
Определяет возможна ли по порту двухсторонняя передача в ту и в другую сторону сигнала. fTXContinueOnXoffОпределяет, останавливается ли передача потока , когда входной буфер становится полный, и драйвер передает сигнал XoffChar. Если этот параметр ИСТИНЕН, передача продолжается после того, как входной буфер становится в пределах XoffLim байтов, и драйвер передает сигнал XoffChar, чтобы прекратить прием байтов из потока . Если этот параметр ЛОЖНЫЙ, передача не продолжается до тех пор , пока входной буфер не в пределах XonLim байтов, и пока не получен сигнал XonChar, для возобновления приема . fOutXОпределяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА в течение передачи потока порту. Если этот параметр ИСТИНЕН, передача останавливается, когда получен сигнал XoffChar и начинается снова, когда получен сигнал XonChar. fInXSpecifies whether XON/XOFF flow control is used during reception. If this member is TRUE, the XoffChar character is sent when the input buffer comes within XoffLim bytes of being full, and the XonChar character is sent when the input buffer comes within XonLim bytes of being empty. Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА в течение приема потока портом. Если этот параметр ИСТИНЕН,сигнал XoffChar посылается , когда входной буфер находится в пределах XoffLim байтов, а сигнал XonChar посылается тогда когда входной буфер находится в пределах XonLim байтов или является пустым fErrorCharОпределяет, заменены ли байты, полученные с ошибками четности особенностью, указанной параметром ErrorChar Если этот параметр ИСТИНЕН, и fParity ИСТИНЕН, замена происходит. fNullОпределяет, отвергнуты ли нулевые(пустые) байты. Если этот параметр ИСТИНЕН, нулевые(пустые) байты, будут отвергнуты при получении их. fRtsControlRTS управление потоком " запрос пересылки ". Если это значение нулевое, то по умолчанию устанавливается RTS_CONTROL_HANDSHAKE. Принимает одно из следующих значений:
Отключает строку RTS, когда устройство открыто
Включает строку RTS
Enables RTS handshaking. The driver raises the RTS line when the "type-ahead" (input) buffer is less than one-half full and lowers the RTS line when the buffer is more than three-quarters full. If handshaking is enabled, it is an error for the application to adjust the line by using the EscapeCommFunction function.
Допускает RTS подтверждение связи. Драйвер управляет потоком пересылки.RTS выравнивается , когда входной буфер - меньше чем половина полного и понижается, когда буфер - больше 2/3 полного .Если подтверждение связи допускается, это используется для регулирования передачи данных EscapeCommFunction.
Specifies that the RTS line will be high if bytes are available for transmission. After all buffered bytes have been sent, the RTS line will be low. Определяет, что буфер будет высокий при подготовке данных для передачи. После того, как все байты отосланы, буфер RTS будет низок.
Если этот параметр ИСТИНЕН, драйвер закрывает все операции чтения/записи с состоянием погрешности при возникновении оной.
Драйвер не будет принимать никакие дальнейшие действия, пока не дождется подтверждения погрешности в передоваемых (принимаемых) данных, вызывая функцию ClearCommError. fDummy2ЗАРЕЗЕРВИРОВАНО Microsoft wReservedЗАРЕЗЕРВИРОВАНО Microsoft XonLimОпределяет минимальное число байтов, находящихся во входном буфере прежде, чем будет генерирована подача СТАРТ-СИГНАЛА XoffLimОпределяет максимальное число байтов, находящихся во входном буфере прежде, чем будет генерирована подача СТОП-СИГНАЛА. Максимальное число байтов, позволенных во входном буфере вычитается из размеров, в байтах, самого входного буфера. ByteSizeОпределяет число битов в байтах, переданных и полученных. ParityОпределяет схему четности, которую нужно использовать. Этот параметр может быть одним из следующих значений: EVENPARITY MARKPARITY NOPARITY ODDPARITY StopBitsОпределяет число стоповых битов, которые нужно использовать.
Этот параметр может быть одним из следующих значений: ONESTOPBIT 1 stop bit ONE5STOPBITS 1.5 stop bits TWOSTOPBITS 2 stop bits XonCharОпределяет значение СТАРТ-СИГНАЛА для передачи и приема. XoffCharОпределяет значение СТОП-СИГНАЛА для передачи и приема. ErrorCharОпределяет значение СИГНАЛА ОШИБКИ (генерируемого при ошибке четности) для передачи и приема. EofCharОпределяет значение сигнала конца данных. EvtCharОпределяет значение сигнала события. wReserved1ЗАРЕЗЕРВИРОВАНО Microsoft
Дополнение :
Когда структура DCB использует «ручной» выбор конфигурации , следующие ограничения используются для ByteSize и StopBits параметров :
Продолжнение следует...
, часть I
20 апреля 2001 г.
Специально для
Часть III - Настройка панелей
Доброе время суток !
Этой статьей я заканчиваю введение в интегрированную картографию MapInfo.Надеюсь, что данный цикл статей открыл вам возможность применять MapInfo в ваших программах. Перед началом я хочу дать вам ссылку на , где вы найдете исчерпывающеюся информацию по MapInfo и MapBasic в частности на русском языке. Многое что я дал вам по MapBasic в этих частях взято оттуда.
Часть III
| , часть I , часть II Вернуться к разделу | авное не знание , а умение его правильно применить» В обход своей статьи по желанию трудящихся масс представляю вашему вниманию еще пример для работы с портами теперь уже с портом LPT реализующий чистый вывод потока на принтер (данный пример взят мной из FAQ собранный Акжаном Абдулиным,за что ему огромное спасибо) Итак… Ниже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP",чтобы функция сработала успешно. Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться. === Cut === uses WinSpool; procedure WriteRawStringToPrinter(PrinterName:String; S:String); var Handle: THandle; N: DWORD; DocInfo1: TDocInfo1; begin if not OpenPrinter(PChar(PrinterName), Handle, nil) then begin ShowMessage('error ' + IntToStr(GetLastError)); Exit; end; with DocInfo1 do begin pDocName := PChar('test doc'); pOutputFile := nil; pDataType := 'RAW'; end; StartDocPrinter(Handle, 1, @DocInfo1); StartPagePrinter(Handle); WritePrinter(Handle, PChar(S), Length(S), N); EndPagePrinter(Handle); EndDocPrinter(Handle); ClosePrinter(Handle); end; procedure TForm1.Button1Click(Sender: TObject); begin WriteRawStringToPrinter('HP', 'Test This'); end; === Cut === unit TextPrinter; interface uses Windows, Controls, Forms, Dialogs; type TTextPrinter = class(TObject) FNumberOfBytesWritten: Integer; FHandle: THandle; FPrinterOpen: Boolean; FErrorString: PChar; procedure SetErrorString; public constructor Create; procedure Write(const Str: string); procedure WriteLn(const Str: string); destructor Destroy; override; published property NumberOfBytesWritten: Integer read FNumberOfBytesWritten; end; implementation {TTextPrinter} constructor TTextPrinter.Create; begin FHandle := CreateFile('LPT1', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0); if FHandle = INVALID_HANDLE_VALUE then begin SetErrorString; raise Exception.Create(FErrorString); end else FPrinterOpen := True; end; procedure TTextPrinter.SetErrorString; begin if FErrorString <> nil then LocalFree(Integer(FErrorString)); FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), LANG_USER_DEFAULT, @FErrorString, 0, nil); end; procedure TTextPrinter.Write(const Str: string); var OEMStr: PChar; NumberOfBytesToWrite: Integer; begin if not FPrinterOpen then Exit; NumberOfBytesToWrite := Length(Str); OEMStr := PChar(LocalAlloc(LMEM_FIXED, NumberOfBytesToWrite + 1)); try CharToOem(PChar(Str), OEMStr); if not WriteFile(FHandle, OEMStr^, NumberOfBytesToWrite, FNumberOfBytesWritten, nil) then begin SetErrorString; raise Exception.Create(FErrorString); end; finally LocalFree(Integer(OEMStr)); end; end; procedure TTextPrinter.WriteLn(const Str: string); begin Self.Write(Str); Self.Write(#10); end; destructor TTextPrinter.Destroy; begin CloseHandle(FHandle); if FErrorString <> nil then LocalFree(Integer(FErrorString)); end; end. === Cut === P.S. В принципе, вместо LPT1 может стоять что угодно, даже сетевой сервер печати (\\server\prn) - все равно печатает. Можно и параметр в конструктор вставить и т.д. Ну на примерах остановились идем далее по теме статьи и продолжаем разбирать работу программы «ПетрВес» в которой я хотел бы остановится на следующем : В своей программе по работе с весами ПетрВес (далее во всех продолжениях цикла -«ПетрВес») ее аммы остановится на таком коде // Первоначальное считывание,приминяется для того что-бы установить // все параметры структур по умолчанию if not Windows.GetCommState(hComm, Mode) or not Windows.GetCommTimeouts(hComm,TimeOuts) then exit Else // у нас все хорошо все считалось нормально ,идем далее.. begin with Mode do Begin BaudRate := 9600; ByteSize := 8; Parity := NOPARITY; StopBits := ONESTOPBIT; Flags := EV_RXCHAR + EV_EVENT2; End; // Устанавливаем таймауты with TimeOuts do Begin ReadIntervalTimeout := MAXDWORD; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 0; End; IF Not SetCommState ( hComm, Mode ) OR Not SetCommTimeOuts(hComm,TimeOuts); Then ShowMessage("Ошибка"); // тут предпринимаем всякие действия // по обработке ошибки End; Итак посмотрим что делает данный код: |
| GetCommState |
Функция GetCommState считывает структуру DCB с указанного порта (данную функцию можно использовать как проверку доступности порта).
Описание в эквиваленте C
BOOL GetCommState( HANDLE hFile, // Дескриптор указывающий на порт (этот дескриптор // может быть создан с помощью CreateFile, OpenFile) LPDCB lpDCB // Структура управления устройством DCB (портом в // нашем случае) );
Параметры :
HFileДескриптор указывающий на порт (этот дескриптор может быть создан с помощью CreateFile, OpenFile) lpDCBСтруктура управления устройством DCB (портом в нашем случае)
Возвращаемое значение :
Если функция выполняется успешно, возвращаемое значение - TRUE иначе возвращаемое значение - FALSE . При возникновении ошибки код ошибки можно получить используя GetLastErro
| SetCommState |
Функция SetCommState конфигурирует настройки порта согласно техническим требованиям указанным в блоке управления устройством (структура DCB). Функция повторно инициализирует все аппаратные средства и установки управления, но не затрагивает очеpеди пеpедачи и пpиема потоков данных.
Описание в эквиваленте C
BOOL SetCommState( HANDLE hFile, // Дескриптор указывающий на порт (этот дескриптор // может быть создан с помощью CreateFile,OpenFile) LPDCB lpDCB // Структура управления устройством DCB (портом в // нашем случае) );
Коротко
Инициализиpует устpойство связи, указанное в поле HFILE блока DCB, в состояние, заданное DCB. Очеpеди пеpедачи и пpиема не затpагиваются.
Параметры :
HFileДескриптор указывающий на порт (этот дескриптор может быть создан с помощью CreateFile, OpenFile) lpDCB Структура управления устройством DCB (портом в нашем случае)
Возвращаемое значение :
Если функция выполняется успешно, возвращаемое значение - TRUE иначе возвращаемое значение - FALSE . При возникновении ошибки код ошибки можно получить используя GetLastError.
Дополнительные сведения:
The SetCommState function uses a DCB structure to specify the desired configuration. The GetCommState function returns the current configuration. To set only a few members of the DCB structure, you should modify a DCB structure that has been filled in by a call to GetCommState. This ensures that the other members of the DCB structure have appropriate values. The SetCommState function fails if the XonChar member of the DCB structure is equal to the XoffChar member.
Функция SetCommState использует структуру DCB, чтобы переинициализировать конфигурацию по умолчанию. Чтобы перенастроить только несколько членов структуры DCB, Вы должны изменить структуру DCB, которая была получена с помощью GetCommState. Это будет гарантировать, что другие члены структуры DCB будут иметь соответствующие значения по умолчанию.
Важно
Функция SetCommState потерпит неудачу, если параметр XonChar структуры DCB будет равен параметру XoffChar.
Для функции SetCommState используются следующие ограничения параметров ByteSize и StopBits структуры DCB:
Продолжнение следует...
, часть I
, часть II
23 апреля 2001 г.
Специально для
Часть IV
| , часть I , часть II , часть III Вернуться к разделу | аммах для Win32 в среде C++» Титова Олега (за что ему очередное спасибо) Следующей важной после DCB управляющей структурой является COMMTIMEOUTS. Она определяет параметры временных задержек при приеме и передаче. Значения, задаваемые полями этой структуры, оказывают большое влияние на работу функций чтения/записи. |
| COMMTIMEOUTS |
Описание в эквиваленте C
typedef struct _COMMTIMEOUTS { DWORD ReadIntervalTimeout; DWORD ReadTotalTimeoutMultiplier; DWORD ReadTotalTimeoutConstant; DWORD WriteTotalTimeoutMultiplier; DWORD WriteTotalTimeoutConstant; } COMMTIMEOUTS,*LPCOMMTIMEOUTS;
Параметры :
ReadIntervalTimeoutМаксимальное время, в миллисекундах, допустимое между двумя последовательными символами считываемыми с коммуникационной линии. Во время операции чтения временной период начинает отсчитываться с момента приема первого символа. Если интервал между двумя последовательными символами превысит заданое значение, операция чтения завершается и все данные, накопленые в буфере, передаются в программу. Нулевое значение данного поля означает, что данный тайм-аут не используется. Значение MAXDWORD, вместе с нулевыми значениями полей ReadTotalTimeoutConstant и ReadTotalTimeoutMultiplier, означает немедленный возврат из операции чтения с передачей уже принятого символа, даже если ни одного символа не было получено из линии. ReadTotalTimeoutMultiplierЗадает множитель, в миллисекундах, используемый для вычисления общего тайм-аута операции чтения. Для каждой операции чтения данное значение умножается на количество запрошеных для чтения символов ReadTotalTimeoutConstantЗадает константу, в миллисекундах, используемую для вычисления общего тайм-аута операции чтения. Для каждой операции чтения данное значение прибавляется к результату умножения ReadTotalTimeoutMultiplier на количество запрошеных для чтения символов. Нулевое значение полей ReadTotalTimeoutMultiplier и ReadTotalTimeoutConstant означает, что общий тайм-аут для операции чтения не используется. WriteTotalTimeoutMultiplierЗадает множитель, в миллисекундах, используемый для вычисления общего тайм-аута операции записи. Для каждой операции записи данное значение умножается на количество записываемых символов. WriteTotalTimeoutConstantЗадает константу, в миллисекундах, используемую для вычисления общего тайм-аута операции записи. Для каждой операции записи данное значение прибавляется к результату умножения WriteTotalTimeoutMultiplier на количество записываемых символов. Нулевое значение полей WriteTotalTimeoutMultiplier и WriteTotalTimeoutConstant означает, что общий тайм-аут для операции записи не используется. По тайм-аутам обычно возникает много вопросов. Поэтому попробую объяснить подробнее. Пусть мы считываем 50 символов из порта со скоростью 9600. При этом используется 8 бит на символ, дополнение до четности и один стоповый бит. Таким образом на один символ в физической линии приходится 11 бит (включая стартовый бит). 50 символов на скорости 9600 будут приниматься 50 * 11 / 9600 = 0.0572916 секунд, или примерно 57.3 миллисекунды, при условии нулевого интервала между приемом последовательных символов. Если интервал между символами составляет примерно половину времени передачи одного символа, т.е. 0.5 миллисекунд, то время приема будет 50 * 11 / 9600 + 49 * 0.0005 = 0.0817916 секунд, или примерно 82 миллисекунды. Если в процессе чтения прошло более 82 миллисекунд, то мы вправе предположить, что произошла ошибка в работе внешнего устройства и прекратить считывание избежав тем самым зависания программы. Это и есть общий тайм-аут операции чтения. Аналогично существует и общий там-аут операции записи.
Если тайм- аут при чтении понятен, то тайм-аут при записи вызывает недоумение. В самом деле, что нам мешает передавать? Управление потоком! Внешнее устройство может использовать, например, аппаратное управление потоком. При этом пропадание питания во внешнем устройстве заставит компьютер приостановить передачу данных. Если не контролировать тайм-аут возможно точно такое же зависание компьютера, как и при операции чтения.
Общий тайм-аут зависит от количества участвующих в операции чтения/записи символов и среднего времени передачи одного символа с учетом межсимвольного интервала. Если символов много, например 1000, то на общем времени выполнения операции начинают сказываться колебания времени затрачиваемого на один символ или времени межсимвольного интервала. Поэтому тайм-ауты в структуре COMMTIMEOUTS задаются двумя величинами. Таким образом формула для вычисления общего тайм-аута операции, например чтения, выглядит так NumOfChar * ReadTotalTimeoutMultiplier + ReadTotalTimeoutConstant, где NumOfChar это число символов запрошеных для операции чтения.
Для операции чтения, кроме общего тайм-аута на всю операцию, задается так же тайм-аут на интервал между двумя последовательными символами. Точнее это интервал между началами двух последовательных символов. В это значение входит и время передачи самого символа.
Теперь небольшой пример.
ReadTotalTimeoutMultiplier = 2, ReadTotalTimeoutConstant = 1, ReadIntervalTimeout = 1,
считывается 250 символов. Если операция чтения завершится за 250 * 2 + 1 = 501 миллисекунду, то будет считано все сообщение. Если операция чтения не завершится за 501 миллисекунду, то она все равно будет завершена. При этом будут возвращены символы, прием которых завершился до истечения тайм-аута операции. Остальные символы могут быть получены следеющей операцией чтения. Если между началами двух последовательных символов пройдет более 1 миллисекунды, то операция чтения так же будет завершена.
Надеюсь, что теперь тайм-ауты не будут вызывать у Вас затруднений. Для завершения темы тайм-аутов рассмотрим один частный случай. Если поля ReadIntervalTimeout и ReadTotalTimeoutMultiplier установлены в MAXDWORD, а ReadTotalTimeoutConstant больше нуля и меньше MAXDWORD, то выполнение операции чтения подчиняется следующим правилам:
| GetCommTimeouts |
Функция GetCommTimeouts считывает структуру _COMMTIMEOUTS с указанного порта и заполняет параметры значениями по умолчанию.
Описание в эквиваленте C
BOOL GetCommTimeouts( HANDLE hFile, LPCOMMTIMEOUTS lpCommTimeouts );
Параметры :
HFileДескриптор указывающий на порт (этот дескриптор может быть создан с помощью CreateFile, OpenFile) LpCommTimeoutsСтруктура LPCOMMTIMEOUTS
Возвращаемое значение :
Если функция выполняется успешно, возвращаемое значение - TRUE иначе возвращаемое значение - FALSE . При возникновении ошибки код ошибки можно получить используя GetLastError
Ну и соответственно -
| SetCommTimeouts |
Функция SetCommTimeouts устанавливает тайм-ауты порта
Описание в эквиваленте C
BOOL SetCommTimeouts( HANDLE hFile, LPCOMMTIMEOUTS lpCommTimeouts );
Параметры :
HFileДескриптор указывающий на порт (этот дескриптор может быть создан с помощью CreateFile, OpenFile) LpCommTimeoutsСтруктура LPCOMMTIMEOUTS
Возвращаемое значение :
Если функция выполняется успешно, возвращаемое значение - TRUE иначе возвращаемое значение - FALSE . При возникновении ошибки код ошибки можно получить используя GetLastError
Параметры этих функций очевидны. Хочется отметить что установку тайм-аутов можно производить как до установки параметров порта, так и после, т.е последовательность вызова функций SetCommState и SetCommTimeouts не имеет значения. Главное, что бы все настройки были завершены до начала ввода/вывода информации.
В продолжении статьи хочется добавить еще оду функцию использование которой несомненно очень нужно для получения данных о портах. Представьте ситуацию, когда под COM1 может скрываться вовсе не привычный порт RS-232, а что нибудь другое. Или порт может не позволять задавать скорость более 9600 бод.
Исчерпывающая информация о возможностях коммуникационного устройства и драйвера содержится в структуре COMMPROP:
| COMMPROP |
Параметры :
wPacketLengthЗадает размер, в байтах, структуры COMMPROP wPacketVersionНомер версии структуры. dwServiceMask Битовая маска. Для коммуникационных устройств всегда SP_SERIALCOMM, включая модемы. dwReserved1Зарезервировано Microsoft dwMaxTxQueueМаксимальный размер, в байтах, внутреннего буфера передачи драйвера. Нулевое значение свидетельствует об отсутствии ограничения. dwMaxRxQueueМаксимальный размер, в байтах, внутреннего буфера приема драйвера. Нулевое значение свидетельствует об отсутствии ограничения. dwMaxBaudМаксимально допустимая скорость обмена, в битах в секунду (бпс). Возможны следующие значения данного поля:
Остановлюсь чуть подробнее на описании некоторых полей. Поле wPacketLength играет несколько иную роль, чем поле DCBlength структуры DCB, хотя из его описания это не следует. Секрет прост. Поле wcProvChar, расположеное в конце структуры, может содержать, а может и не содержать, данных. Вы не в состоянии это узнать не запросив информацию. В свою очередь, перед запросом информации Вы должны выделить (и обнулить) память под структуру COMMPROP. Поэтому последовательность шагов для получения всей информации следующая:
, часть I
, часть II
, часть III
25 апреля 2001 г.
Специально для
Часть V
| , часть I , часть II , часть III , часть IV Вернуться к разделу |
«Все новое ,это хорошо забытое старое»
Данная 5 часть полностью взята из статьи «Работа с коммуникационными портами (COM и LPT) в программах для Win32 в среде C++» Титова Олега.
Это было сделано для полноты цикла по теме, просто не будем заново изобретать велосипед и продолжим разговор о работе с портам, основываясь на статье Титова Олега.
Получить информацию об устройстве в виде структуры COMMPROP можно функцией GetCommProperies.
Вот ее описание в эквиваленте С BOOL GetCommProperties( HANDLE hFile, LPCOMMPROP lpCommProp );
Следует отметить, что запросить информацию можно только об уже открытом устройстве, т.е устройстве открытом функциями CreateFile OpenFile.
Так-же для структуры lpCommProp должна быть предварительно выделена память.
Смысл применения данной функции становится понятен в той ситуации когда невозможно жестко зашить в код программы настройки порта, т.к внешние устройства могут позволять изменять параметры линии связи, чаще всего скорость обмена, которая зависит от длины соединительного кабеля.
Как раз в таких случаях разумно в программе самому предоставить возможность настройки режимов обмена, а можно воспользоваться установками по умолчанию предоставленными для данного порта.
Стандартый диалог выводится функцией CommConfigDialog, которая работает со структурой COMMCONFIG. Как и в случае со структурой DCB, заполнять структуру COMMCONFIG можно вручную или вызовом соответсвующих функций. Начнем с самой структуры COMMCONFIG:
typedef struct _COMM_CONFIG { DWORD dwSize; WORD wVersion; WORD wReserved; DCB dcb; DWORD dwProviderSubType; DWORD dwProviderOffset; DWORD dwProviderSize; WCHAR wcProviderData[1]; } COMMCONFIG, *LPCOMMCONFIG; Основной частью этой структуры является уже знакомый нам DCB. Остальные поля содержат вспомогательную информацию, которая, для наших целей, не представляет особого интереса (однако эта информация может быть полезной для получения дополнительных данных о порте). Познакомимся поближе с полями:
dwSize Задает размер структуры COMMCONFIG в байтах wVersion Задает номер версии структуры COMMCONFIG. Должен быть равным 1. wReserved Зарезервировано и не используется dcb Блок управления устройством (DCB) для порта RS-232. dwProviderSubType Задает тип устройства и формат устройство-зависимого блока информации. Фактически это тип порта. Конкретные значения данного поля приведены в описании структуры COMMPROP выше. dwProviderOffset Смещение, в байтах, до устройство-зависимого блока информации от начала структуры. dwProviderSize Размер, в байтах, устройство-зависимого блока информации. wcProviderData Устройство-зависимый блок информации. Это поле может быть любого размера или вообще отсутствовать. Поскольку структура COMMCONFIG может быть в дальшейшем расширена, для определения положения данного поля следует использовать dwProviderOffset. Если dwProviderSubType PST_RS232 или PST_PARALLELPORT, то данное поле отсутствует. Если dwProviderSubType PST_MODEM, то данное поле содержит структуру MODEMSETTINGS.
Не смотря на то, что нам нужен только DCB, приходится иметь дело со всеми полями. Заполнение данной структуры противоречивыми данными может привести к неправильной настройке порта, поэтому следует пользоваться функцией GetCommConfig: BOOL GetCommConfig( HANDLE hCommDev, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ); Параметры функции следующие: hCommDev Описатель открытого коммуникационного порта. lpCC Адрес выделеного и заполненого нулями, кроме поля dwSize, блока памяти под структуру COMMCONFIG. В поле dwSize нужно занести размер структуры COMMCONFIG. После вызова функции все поля структуры будут содержать информацию о текущих параметрах порта. lpdwSize Адрес двойного слова, которое после воврата из функции будет содержать число фактически переданных в структуру байт. В случае успешного завершения функция возвращает ненулевое значение.
Как всегда не обошлось без тонкостей. Структура COMMPROP имеет перемнную длину, поэтому затруднительно сразу выделить требуемый блок памяти. Как и в случае с функцией GetCommProperties, функцию GetCommConfig придется вызывать дважды:
Теперь, имея заполненую корректной информацией структуру COMMCONFIG, можно позволить пользователю выполнить настройку параметров с помощью функции CommConfigDialog: BOOL CommConfigDialog( LPTSTR lpszName, HWND hWnd, LPCOMMCONFIG lpCC ); Вызов этой функции приводит к отображению диалогового окна. Вид окна может отличаться от приведенного. Это зависит от операционной системы и динамической библиотеки, предоставленной производителем порта.
Познакомимся с параметрами функции CommConfigDialog: lpszName Указатель на строку с именем порта для которого отображается диалоговое окно. К реальному имени порта эта строка не имеет никакого отношения, она просто выводится в заголовке окна. hWnd Описатель окна, которое владеет данным диалоговым окном. Должен быть передан корректный описатель окна-владельца или NULL, если у диалогового окна нет владельца. lpCC Указатель на структуру COMMCONFIG. Эта структура содержит начальные установки используемые для отображения в диалоговом окне, и установленные пользователем изменения, при завершении диалога. Как и большинство других функций Win32 API, функция CommConfigDialog возвращает отличное от нуля значение, в случае успешного завершения, и нуль, если возникла ошибочная ситуация.
Функция CommConfigDialog не выполняет настройки порта. Она все лишь позволяет пользователю изменить некоторые поля в блоке DCB, содержащемся в структуре COMMCONFIG. Разумеется, Вы можете изменить установленые пользователем некорректные значения или выполнить дополнительные настройки после вызова функции GetCommConfig. Фактическая настройка порта выполняется функцией SetCommConfig:
BOOL SetCommConfig( HANDLE hCommDev, LPCOMMCONFIG lpCC, DWORD dwSize );
Параметры имеют тоже самое значение, как и в функции GetCommConfig. Следует заметить, что описаные три функции позволяют настраивать и некоторые параметры модема, если он подключен к порту и опознан системой. Впрочем, эта возможность может отсутствовать, если она не предусмотрена производителем оборудования.
Обратите внимание на кнопку "Restore Defaults". Вы в состоянии управлять ее поведением, правда опосредовано, с помощью функций GetDefaultCommConfig и SetDegaultCommConfig. Вот их прототипы: BOOL GetDefaultCommConfig( LPCSTR lpszName, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ); BOOL SetDefaultCommConfig( LPCSTR lpszName, LPCOMMCONFIG lpCC, DWORD dwSize ); Эти функции очень похожи на GetCommConfig и SetCommConfig, но предназначены совсем для другой цели. Предположим, что Ваше устройство, по умолчанию, работает на скорости 175 бит в секунду и обменивается пятибитными символами. Системные же умолчания - 9600 бит в секунду и 8 бит в символе. Что бы пользователь, при нажатии на кнопку "Restore Defaults", получал не системные, а Ваши умолчания, воспользуйтесь функциями GetDefaultCommConfig и SetDefaultCommConfig. SetDefaultCommConfig не настраивает порт, это выполняется функцией SetCommConfig, а изменяет параметры во внутренней области коммуникационного драйвера.
Теперь познакомимся с функцией SetupComm, которая, на самом деле, совсем не то, что следует из названия. BOOL SetupComm( HANDLE hFile, DWORD dwInQueue, DWORD dwOutQueue ); Эту функцию скорее следовало назвать SetCommQueueSize, поскольку все, что она делает, это устанавливает размеры (в байтах) очередей приема и передачи. Причем размеры рекомендуемые. В общем случае, система сама в состоянии определить требуемый размер очередей, однако Вы можете вмешаться в этот процесс. Внутренние очереди драйвера позволяют избежать потери данных, если Ваша программа не успевает их считывать, и пауз в работе программы, если она передает данные слишком быстро. Размер очереди выбирается немного большим максимальной длины сообщения. Например, для протокола YMODEM, пакет данных которого имеет длину 1024 байт, разумным размером очереди будет 1200 байт.
Указаный Вами размер очереди будет принят драйвером к сведению. Но он оставляет за собой право внести коррективы или вообще отвергнуть устанавливаемое значение. В последнем случае функция завершится с ошибкой.
Внешние устройства управления объектами, чаще всего подключаемые к портам, обычно обмениваются с компьютером короткими сообщениями. Соответственно и вызов функции SetupComm не требуется. Однако, если Ваше устройство передает или принимает блоки данных длиной в несколько тысяч байт, рекомендуется установить размеры очередей драйвера.
Давайте сделаем паузу в изучении функций настройки и получения состояния коммуникационных портов. Пора от слов переходить к делу, а именно к приему и передаче данных. Начнем с синхронного чтения/записи, это проще.
Прием и передача данных выполняется функциями ReadFile и WriteFile, то есть теми же самыми, которые используются для работы с дисковыми файлами. Вот как выглядят прототипы этих функций:
BOOL ReadFile( HANDLE hFile, LPVOID lpBuffer, DWORD nNumOfBytesToRead, LPDWORD lpNumOfBytesRead, LPOVERLAPPED lpOverlapped ); BOOL WriteFile( HANDLE hFile, LPVOID lpBuffer, DWORD nNumOfBytesToWrite, LPDWORD lpNumOfBytesWritten, LPOVERLAPPED lpOverlapped );
Вы наверняка работали с этими функциями и знаете значение их параметров. Но я все таки кратко остановлюсь на их описании:
hFile Описатель открытого файла коммуникационного порта lpBuffer Адрес буфера. Для операции записи данные из этого буфера будут передаваться в порт. Для операции чтения в этот буфер будут помещаться принятые из линии данные. nNumOfBytesToRead, nNumOfBytesToWrite Число ожидаемых к приему или предназначеных к передаче байт. nNumOfBytesRead, nNumOfBytesWritten Число фактически принятых или переданых байт. Если принято или передано меньше данных, чем запрошено, то для дискового файла это свидетельствует об ошибке, а для коммуникационного порта совсем не обязательно. Причина в тайм-аутах. lpOverlapped Адрес структуры OVERLAPPED, используемой для асинхронных операций. Подробнее как с структурой, так и с асинхронными операциями мы познакомимся позже. Для синхронных операций данный параметр должен быть равным NULL.
Еще раз коснусь темы тайм-аутов. Если Вы не используете ни общий, ни межбайтный тайм-ауты для операции чтения и внешнее устройство прекратило передачу, то Ваша программа будет вечно ждать завершения синхронной операции. Другими словами она зависнет. Аналогичный результат может быть при использовании программного или аппаратного управления потоком. Если же тайм- ауты используются, то операция чтения нормально завершится. Только количество считанных байт будет меньше количества запрошеных для чтения. Это не обязательно свидетельствует об ошибке. Например программа может по тайм-ауту определять конец очередного блока данных. Аналогично и для операции записи, с той лишь разницей, что неполная передача данных из буфера, скорее всего, будет свидетельствовать о проблеме во внешнем устройстве. То есть будет считаться ошибкой.
Коммуникационный порт не совсем обычный файл. Например, для него нельзя выполнить операцию позиционирования файлового указателя. С другой стороны, порт позволяет управлять потоком, что нельзя делать с обычным файлом. Настало время познакомиться с функциями управления приемом/передачей данных через коммуникационные порты. Поскольку первой операцией, после открытия порта, является его сброс, то и начнем с функции выполняющей требуемые действия. BOOL PurgeComm( HANDLE hFile, DWORD dwFlags );
Вызов этой функции позволяет решить две задачи: очистить очереди приема/передачи в драйвере и завершить все находящиеся в ожидании запросы ввода/вывода. Какие именно действия выполнять задается вторым параметром (значения можно комбинировать с помощью побитовой операции OR:
Следует помнить, что очистка буфера передачи, как и экстреное завершение операции записи, не выполняют передачу данных находящихся в этом буфере. Данные просто отбрасываются. Если же передача остатка данных необходима, то перед вызовом PurgeComm следует вызвать функцию: BOOL FlushFileBuffers( HANDLE hFile );
Если на COM2 установить перемычку между сигналами TxD и RxD, то переменная buf_in, после выполнения ReadFile, будет содержать ту же информацию, что и buf_out. Других пояснений пример не требует, все уже было подробно рассмотрено раньше.
Иногда требуется срочно передать символ, имеющий определенное специальное значение, а в очереди передатчика уже есть данные, которые нельзя терять. В этом случае можно воспользоваться функцией: BOOL TransmitCommChar( HANDLE hFile, char cChar );
Данная функция передает один (и только один) внеочередной байт в линию, не смотря на наличие данных в очереди передатчика, и перед этими данными. Однако управление потоком действует. Функцию можно вызвать только синхронно. Более того, если байт экстренных данных, от предыдущего вызова этой функции, еще не передан в линию (например из-за функций управления потоком), то попытка экстренной передачи еще одного байта завершится ошибкой. Если Вы используете программное управление потоком, то символы приостановки и возобновления передачи (обычно CTRL-S и CTRL-Q), лучше всего передавать именно этой функцией.
Последовательный канал передачи данных можно перевести в специальное состояние, называемое разрывом связи. При этом передача данных прекращается, а выходная линия переводится в состояние "0". Приемник, обнаружив, что за время необходимое для передачи стартового бита, битов данных, бита четности и стоповых битов, приемная линия ни разу не перешла в состояние "1", так же фиксирует у себя состояние разрыва. BOOL SetCommBreak( HANDLE hFile ); BOOL ClearCommBreak( HANDLE hFile );
Следует заметить, что состояние разрыва линии устанавливается аппаратно. Поэтому нет другого способа возобновить прерваную, с помощью SetCommBreak, передачу данных, кроме вызова ClearCommBreak.
Более тонкое управление потоком данным позволяет осуществить функция: BOOL EscapeCommFunction( HANDLE hFile, DWORD dwFunc ); Выполняемое действие определяется вторым параметром, который может принимать одно из следующих значений:
Эта функция не только сбрасывает признак ошибки для соответсвующего порта, но и возвращает более подробную информацию об ошибке. Кроме того, возможно получение информации о текущем состоянии порта. Вот что означают параметры: hFile Описатель открытого файла коммуникационного порта. lpErrors Адрес переменной, в которую заносится информация об ошибке. В этой переменной могут быть установлены один или несколько из следующих бит:
Если с информацией об ошибке все ясно, то со структурой COMMSTAT мы еще не встречались. Вот она: typedef struct _COMSTAT DWORD fCtsHold:1; DWORD fDsrHold:1; DWORD fRlsdHold:1; DWORD fXoffHold:1; DWORD fXoffSent:1; DWORD fEof:1; DWORD fTxim:1; DWORD fReserved:25; DWORD cbInQue; DWORD cbOutQue; } COMSTAT, *LPCOMSTAT;
Поля структуры имеют следующее значение:
fCtsHold Передача приостановлена из-за сброса сигнала CSR. fDsrHoldПередача приостановлена из-за сброса сигнала DSR. fRlsdHold Передача приостановлена из-за ожидания сигнала RLSD (receive-line-signal-detect). Более известное название данного сигнала - DCD (обнаружение несущей). fXoffHold Передача приостановлена из-за приема символа XOFF. fXoffSent Передача приостановлена из-за передачи символа XOFF. Следующий передаваемый символ обязательно должен быть XON, поэтому передача собственно данных тоже приостанавливается fEof Принят символ конца файла (EOF). fTxim В очередь, с помощью TransmitCommChar, поставлен символ для экстреной передачи. fReserved Зарезервировано и не используется cbInQue Число символов в приемном буфере. Эти символы приняты из линии но еще не считаны функцией ReadFile. cbOutQue Число символов в передающем буфере. Эти символы ожидают передачи в линию. Для синхронных операций всегда 0.
Теперь Вы знаете почти все о работе с последовательными и параллельными портами в синхронном режиме. Особенности непосредственной работы с модемами я не буду рассматривать, так как существует большой набор высокоуровневых функций и протоколов, таких как TAPI, специально предназначеных для работы с модемами. Если Вас все же интересует эта тема, то почитайте описания функции GetCommModemStatus, и структур MODEMDEVCAPS и MODEMSETTINGS. В остальном работа с модемом ничем не отличается от работы с обычным портом.
Синхронный режим обмена довольно редко оказывается подходящим для серьезной работы с внешними устройствами через последовательные порты. Вместо полезной работы Ваша программа будет ждать завершения ввода/вывода, ведь порты работают значительно медленнее процессора. Да и гораздо лучше отдать время процессора другой программе, чем крутиться в цикле ожидая какого-либо события. Другими словами, пришло время знакомиться с асинхронной работой с портами.
Начнем с событий связаных с последовательными портами. Вы указываете системе осуществлять слежение за возникновением связанных с портом событий устанавливая маску с помощью функции BOOL SetCommMask( HANDLE hFile, DWORD dwEvtMask ); Маска отслеживаемых событий задается вторым параметром. Можно указывать любую комбинацию следующих значений:
Вторым параметром задается адрес переменной принимающей значение текущей установленой маски отслеживаемых событий. В дополнение к событиям, перечисленым в описании функции SetCommMask, данная функция может возвратить следующие:
Когда маска отслеживаемых событий задана, Вы можете приостановить выполнение своей программы до наступления события. При этом программа не будет занимать процессор. Это выполняется вызовом функции BOOL WaitCommEvent( HANDLE hFile, LPDWORD lpEvtMask, LPOVERLAPPED lpOverlapped, );
Замечу, что в переменной, адресуемой вторым параметром, не будут устанавливаться внутренние события драйвера (перечислены в описании функции GetCommMask). В единичное состояние установятся только те биты, которые соответствуют реально произошедшим событиям.
Адрес структуры OVERLAPPED требуется для асинхронного ожидания (возможно и такое). Однако пока будем полагать, что порт открыт для синхронных операций, следовательно этот параметр должен быть NULL. Замечу только, что при асинхронном ожидании данная функция может завершиться с ошибкой, если в процессе этого ожидания будет вызвана функция SetCommMask для переустановки маски событий. Кроме того, связанное со структурой OVERLAPPED событие (объект создаваемый функцией CreateEvent, а не событие порта) должно быть с ручным сбросом. Вообще, поведение функции с ненулевым указателем на структуру OVERLAPPED аналогично поведению функций чтения и записи.
Освобождать процессор на время ожидания хорошо, но хотелось бы параллельно с вводом/выводом делать какую-либо полезную работу. Что бы это стало возможным, необходимо в качестве параметра dwFlagsAndAttributes вместо 0 указать FILE_FLAG_OVERLAPPED. Кроме того, для функций ReadFile, WriteFile и WaitCommEvent необходимо в качестве параметра lpOverlapped указывать адрес правильно инициализированной структуры OVERLAPPED. Вот как выглядит эта структура: typedef struct _OVERLAPPED { DWORD Internal; DWORD InternalHigh; DWORD Offset; DWORD OffsetHigh; HANDLE hEvent; } OVERLAPPED, *LPOVERLAPPED
Подробно описывать поля этой структуры не буду, поскольку данная статья не о файловом вводе/выводе вообще, а о работе с портами. Для наших целей, за исключением WaitCommEvent, можно просто обнулить все поля этой структуры. Для WaitCommEvent поле hEvent должно содержать корректный описатель объекта "событие". Что бы все стало понятно, надо разобраться с таким обязательным атрибутом параллельной работы как синхронизация.
ВНИМАНИЕ!!! Дескриптор файла, в данном случае дескриптор файла порта, является синхронизирующим объектом ядра (согласно официальной документации Microsoft). Это означает, что его можно использовать в функциях ожидания событий наравне с дескрипторами событий. Таким образом в поле hEvent в структуре OVERLAPPED можно занести NULL и ожидать освобождения дескриптора файла, а не дескриптора события. Это действительно работает в Windows NT. Однако в Windows95/98 все совсем иначе. Обсуждение ошибок, неточностей и прочих проблем документации оставим в стороне. Просто замечу, что в Windows95/98 поле hEvent должно содержать корректный дескриптор объекта event В ЛЮБОМ СЛУЧАЕ!!! Иначе функции асинхронного ввода/вывода будут работать более чем странным образом. Кроме того, мы должны ожидать освобождения именно дескриптора этого события, а не дескриптора файла.
Синхронизация нужна для упорядочения доступа к совместно используемым объектам. Предположим, что две программы одновременно пытаются изменить значение общей переменной. Каков будет результат? Скорее всего неопределенный. Что бы этого избежать требуется разрешать доступ второй программы к переменной только после того, как с ней закончила работать первая программа.
Для синхронизации используются различные методы: семафоры, блокировки, события, критические секции и т.п. События являются простейшими синхронизирующими объектами. Они могут находиться только в двух состояниях: установленом (событие произошло или наступило) и сброшеном (собитие не произошло или не наступило). События создаются функцией CreateEvent и разрушаются функцией CloseHandle. Установить событие можно функцией SetEvent, а сбросить ResetEvent.
Фнкции записи/чтения для файла открытого для асинхронного ввода/вывода будут немедленно возвращать управление с кодом ошибки ERROR_IO_PENDING. Это означает, что асинхронная операция успешно стартовала. Если возвращается другой код ошибки, то операция не стартовала (например из-за ошибки в параметрах). Теперь Вы можете спокойно заниматься другой работой периодически проверяя, завершилась ли операция ввода/вывода. Эта проверка выполняется функцией BOOL GetOverlappedResult( HANDLE hFile, LPOVERLAPPED lpOverlapped, LPDWORD lpcbTransfer, BOOL fWait );
Параметр hFile определяет дескриптор опрашиваемого файла, lpOverlapped задает адрес структуры OVERLPPED. Третий параметр задает адрес переменной, куда будет помещено количество считанных или записанных байт. Соответсвующий параметр функций ReadFile и WriteFile, хоть и ДОЛЖЕН БЫТЬ ЗАДАН НЕ НУЛЕВЫМ, не позволяет получить количество переданных байт, так как на момент возврата управления из функций чтения/записи не передано ни одного байта. Параметр fWait означает, должна ли функция GetOverlappedResult ждать завершения операции ввода/вывода. Если этот параметр равет FALSE, то функция немедленно вернет управление. При этом код возврата будет TRUE, если операция завершена, или FALSE, если операция не завершена. В послед случае код ошибки возвращаемой функцией GetLastError будет ERROR_IO_INCOMPLETE. Если функция GetOverlappedResult завершилась с кодом возврата FALSE, и другим кодом ошибки, то ошибка произошла именно при вызове самой функции. Если параметр fWait равен TRUE, то функция будет дожидаться завершения операции ввода-вывода.
Замечу, что ожидать завершения ввода/вывода с помощью функции GetOverlappedResult не самое правильное решение. При работе с дисковым файлом операция завершится гарантированно, а при работе с последовательным или параллельным портом совсем не обязательно. Представьте, что Вы не настроили тайм-ауты последовательного порта, а подключенное устройство неисправно. GetOverlappedResult будет ждать вечно, так как нет способа указать максимальное время ожидания. Ждать завершения ввода/вывода лучше с помощью функций: DWORD WaitForSingleObject( HANDLE hObject, DWORD dwTimeot ); DWORD WaitForMultipleObjects( DWORD cObjects, LPHANDLE lpHandles, BOOL bWaitAll, DWORD dwTimeout );
Как следует из названия, эти функции предназначены для ожидания одного или нескольких объектов. Однако следует вспомнить примечание, которое я привел к описанию структуры OVERLAPPED! Поэтому не мудрствуя лукаво будем ожидать только объекты event.
Функция WaitForSingleObject ожидает только один объект задаваемый первым параметром. Вторым параметром задается максимальное время ожидания наступления события в миллисекундах. Если вместо времени указана магическая величина INFINITE, то событие будет ожидаться вечно.
Функция WaitForMultipleObjects ждет несколько событий. Первый параметр указывает сколько именно, а второй задает массив дескрипторов этих событий. Замечу, что один и тот же дескриптор нельзя указывать в этом массиве более одного раза. Третий параметр задает тип ожидания. Если он равен TRUE, то ожидается наступление всех событий. Если FALSE, то наступления любого одного из указанных. И естественно тоже можно задать максимальное время ожидания последним параметром.
Если событие наступило, то функции возвращают значения от WAIT_OBJECT_0 до WAIT_OBJECT_0+cObject-1. Естественно, что WaitForSingleObject может вернуть только WAIT_OBJECT_0 (если конечно не произошло ошибки). Если произошла ошибка, то будет возвращено WAIT_FAILED. При превышении максимального времени ожидания функции вернут WAIT_TIMEOUT.
Вернусь к объектам event, которые мы собственно и используем для ожидания. Поясню, почему для наших целей требуются события с ручным сбросом. Функции ReadFile и WriteFile в асинхронном режиме первым делом сбрасывают (переводят в занятое состояние) как дескриптор файла, так и дескриптор объекта event задананный в структуре OVERLAPPED. Когда операция чтения или записи завершается система устанавливает эти дескрипторы в свободное состояние. Тут все логично. Однако и функции WaitForSingleObject и WaitForMultipleObjects для событий с автоматическим сбросом так же выполняют их перевод в занятое состояние при вызове. Для событий с ручным сбросом этого не происходит. Теперь представьте, что операция ввода/вывода завершилась ДО вызова WaitForSingleObject. Представили? Для событий с автоматическим сбросом снова будет выполнен перевод объекта в занятое состояние. Но освобождать то его будет некому! Более подробная информация об объектах event выходит за рамки этой статьи.
Теперь небольшой пример на С. Все подробности, не относящиеся к работе в асинхронном режиме я опускаю. #include
В этом примере переменная bc, предназначенная для получения количества считанных байт, после вызова ReadFile будет равна 0, так как никакой передачи информации еще не было. После вызова GetOverlappedResult в эту переменную будет помещено число реально считанных байт.
Безусловно, можно придумать очень сложные схемы распараллеливания ввода/вывода и вычислений, базирующиеся на использовании асинхронных операций и объектов event. Позволю себе не приводить реально работающих примеров программ. Таких программ работающих в реальном масштабе времени много, но они очень сложны и громоздки для этой статьи.
Вернемся ненадолго с структуре OVERLAPPED и функциям ReadFile и WriteFile. Для дискового ввода/ вывода возможно задать одновременно несколько конкурирующих операций чтения/записи. Однако для каждой такой операции необходимо использовать свою структуру OVERLAPPED. Для работы с портами нельзя задавать конкурирующие операции. Точнее можно, но только в Windows NT. Поэтому для целей совместимости лучше этого не делать.
Теперь, уже совсем кратко, еще об одной возможности, реализованной только в Windows NT. Речь идет о "тревожном вводе-выводе". Эта возможность реализуется функциями ReadFileEx, WriteFileEx и SleepEx. Суть использования данных функий такова. Вы вызываете расширенную функцию записи или чтения, которая имеет еще один параметр - адрес функции завершения. После чего, вызвав расширенную функцию засыпания, освобождаете процессор. После завершения ввода/вывода Ваша функция завершения будет вызвана системой. Причем вызвана ТОЛЬКО в том случае, если ваша программа вызвала SleepEx. Нетрудно заметить, что данный вариант работы подходит для систем с большим количеством портов и работающих в режиме ответа по требованию. Например, сервер с мультипортовым контроллером последовательного порта, к которому подключены модемы.
Теперь, но ОЧЕНЬ кратко, залезем в еще большие дебри. Предположим, что протокол обмена с Вашим устройством, подключенным к последовательному порту, очень сложен (передаются большие и сложные структуры данных). При этом Ваша программа должна получать уже полностью принятую и проверенную информацию. Предположим так же, что Ваша программа занимается очень большими и сложными вычислениями и ей нет времени отвлекаться на обработку ввода/вывода. Да и сложность ее такова, что встраивание фонового ввода/вывода сделает ее трудно прослеживаемой и неустойчивой. Чувствуете, куда я клоню? Правильно, к выделению всех тонкостей ввода/вывода в отдельный поток. Возможно выделение и в отдельную задачу, но в этом случае мы не получим никакой выгоды, а накладные расходы на переключение задач гораздо больше, нежели на переключение потоков в одной задаче.
Потоки создаются функцией CreateThread, и уничтожаются функциями ExitThread и TerminateThread. Принцип работы таков. Вы создаете поток. При этом управление получает Ваша функция потока. Она работает параллельно, как минимум, основному потоку Вашей программы. Функция открывает порт и выполняет все необходимые настройки. Затем она выполняет весь ввод/вывод, при чем совершенно не важно, используется синхронный или асинхронный режим. При засыпании потока (при синхронном режиме) остальные потоки Вашей программы продолжат выплняться. Когда завершится необходимый обмен информацией с устройством и данные будут готовы для передачи основной программе Ваш поток установит некий флаг, котрый будет воспринят основной программой как готовность данных. После их обработки и формирования блока выходной информации основной поток установит другой флаг, который будет воспринят потоком ввода-вывода как готовность данных для передачи. При этом в качестве флагов можно использовать как объекты event, так и обычные переменные (ведь все потоки задачи выполняются в едином адресном прогстранстве). В случае использования обычных глобальных переменных не забудте в их определения добавить модификатор volatile. Он обозначает, что переменная может измениться асинхронно и компилятор не должен строить иллюзий насчет возможности ее оптимизации. В противном случае у Вас ничего не получится. Так как в потоке ввода/вывода, выполняющемся параллельно основному потоку программы, можно использовать асинхронный ввод/вывод, то достаточно просто реализуется возможность обработки большого количества портов. Фактически поток ввода/вывода будет работь еще и параллельно самому себе. При запуске такой задачи на многопроцессорной машине выгода от использования многопоточности будет очевидна, поскольку потоки будут выполняться на разных процессорах.
В заключении я хочу добавить следующее: в следующих циклах я хочу более подробно рассказать о внутреннем устройстве портов.
Еще раз повторяюсь что данная часть полностью взята из «Работа с коммуникационными портами (COM и LPT) в программах для Win32 в среде C++» Титова Олега, дабы исключить обвинения в плагиате.
Что делает настройщик
Допустим, что у настройщика установлена чистая платформа, т.е. нет ни одной таблицы пользовательской базы данных, более того, на SQL-сервере нет даже системной базы данных. Производится первый запуск приложения платформы. Опустим операции, связанные с подключением к серверу баз данных, т.к. они сейчас не представляют интереса. Исходное состояние системы после загрузки приложения описывается так:Начнем с простейшей задачи, когда нужно создать базу данных клиентов некой фирмы и обеспечить пользовательский интерфейс для ввода, просмотра, редактирования данных и получения несложных отчетов, например, списков клиентов, отобранных по каким-либо признакам.
На Рисунок 1 показано, как выглядит один из ключевых моментов запуска штатной системы.
Рисунок 1
В этих условиях существует лишь одна возможность продвинуться вперед – продолжить загрузку в режиме конфигуратора, установив флаг Конфигуратор. Как видите, у системы нет даже имени. Сразу после входа в конфигуратор настройщик устанавливает ряд параметров, в том числе название системы.
План действий настройщика таков:
При выходе из каждого пользовательского режима система будет запоминать сделанные настройки. После всего этого программа готова для передачи заказчику. В этой публикации речь пойдет о том, как реализовать приведенный перечень действий, что собственно и позволит читателям получить достаточно четкое представление об устройстве платформы. При этом будут представлены работающие приложения, на базе которые, как надеется е манипуляции (создание, модификация, удаление таблиц и полей) будем выполнять сквозным путем, т.е. как в памяти, так и в системной и пользовательской базах данных. При этом существенно упрощаются программные реализации, хотя резко снижается надежность работы приложения, т.к. у пользователя нет промежуточных ступеней отката.
К этому добавлю, что для желающих а готов рассказать о штатной платформе. Итак, в памяти создается структура TTableInfo, содержащая атрибуты, вводимые через специальный диалог. Затем создается набор структур для полей таблицы. Для выполнения этой работы нужно разработать по крайней мере два диалога, - один для заполнения структуры TTableInfo, а другой для заполнения структуры TFieldInfo и ее добавления в структуру TTableInfo. Упрощенные реализации этих диалогов имеют вид, приведенный в листингах L1 и L2.
Листинг L1.
, приведенного в листинге L1.
Рассмотрим некоторые детали этого диалога, относящиеся к общей идеологии платформы, о которых пока не было ничего сказано. Это касается свойства ppTInfoCategory, обеспечивающего доступ к полю FpTInfoCategory : pTInfoCategory, содержащему ссылку на структуру
| // Структура категории информации TInfoCategory = record sInfoID : TFbMedID; sTFbDbType : TFbDbType; sEnumName, sInfoName : TFbMedName; sInfoDescr : TFbMedDesc; sCount : Integer; sPrefix : String[5]; sMainPrefix : String[3]; sSubPrefix : String[2]; sStatusID : Byte; end; |
| sInfoID = ‘001111’, sTFbDbType = icClient, sEnumName = ‘icClient’, sInfoName = ‘InfoName_001111’, sInfoDescr = ‘Клиенты’, sPrefix = ‘Fb_c’, sMainPrefix = ‘Fb_’, sSubPrefix = ‘c_’. |
специальный перечислимый тип
| // Тип категорий информации TFbDbType = ( icOther, // Прочие icSpr, // Справочники icClient, // Клиенты icStaff, // Персонал icStatist, // Статистика icJournal, // Журналы icAll, // Все категории icNoCateg); // Без категории, |
| // Тип паспорта категории информации TFbDbTypeItem = Array [1..2] of String; // Тип массива паспортов категорий информации TFbDbTypeArray = Array [TFbDbType] of TfbDbTypeItem, |
| apDbTypeArray : TFbDbTypeArray = ( { Категория информации и префиксы имен таблиц } { , } ('Прочие', 'Fb_o_'), ('Справочники', 'Fb_s_'), ('Клиенты', 'Fb_c_'), ('Персонал', 'Fb_m_'), ('Статистика', 'Fb_r_'), ('Журналы', 'Fb_j_'), ('Виртуальная БД', 'Fb_v_'), ('Все категории', 'Fb___'), ('Без категории', 'Fb_' ) ) |
Вернемся к нашему диалогу формирования структуры таблицы. Суть его работы сводится к формированию специальной буферной структуры таблицы FN_pTTableInfo для текущего экземпляра интерфейса к базам данных (по клику на кнопке ОК) в методе FDbInterface.Init_NpTTableInfo и переходу в диалог работы со списком полей TbDefFr. Если при выходе из диалога TbDefFr пользователь откажется от создания таблицы, то буферная структура будет удалена из памяти. Если же процесс создания таблицы будет завершен успешно, то судьба буферной структуры поля окончательно будет решена после выхода из диалога TbDefFr. Сама буферная структура FN_pTTableInfo является принадлежностью интерфейса к базам данных FDbInterface.
Ниже приводится программный код для диалога создания структуры поля.
Листинг L2.
, приведенного в листинге L2.
Прежде чем пояснить работу диалога формирования структур полей, поговорим о типах данных, используемых в платформе.
Что же, все-таки, можно сделать
Есть три базовых идеи, три "кита", на основе которых можно построить надежный таймерный сервер:Функция Sleep имеет дискретность отработки заданного интервала (по результатам эксперимента) 10 мс в Windows NT и примерно 3-4 мс в Windows 98. Во многих случаях достаточно просто вызвать эту функцию там, где нужна задержка, если потоку больше нечем заняться в течение этого интервала времени.
Цикл в отдельном потоке с вызовом Sleep с постоянным интервалом и опросом списка таймерных объектов (у каждого свой интервал, заданный клиентом) с определением момента срабатывания, позволяет обрабатывать столько виртуальных таймеров, сколько потребуется программе. Высокий приоритет, заданный потоку, даст возможность таймерам "тикать" даже тогда, когда другие потоки заняты работой.
Использование библиотеки классов, инкапсулирующих системные средства межпоточного взаимодействия (см. статью ) позволит клиентам выбирать наиболее подходящий для конкретного случая способ извещения.
COM:Агрегация и нотификация вообще и для Дельфи в частности.
| Раздел Подземелье Магов | Виталий Маматов , дата публикации 07 августа 2000г. |
Вступление.
К написанию данной статьи меня подтолкнула моя недавняя пробежка по вопросам относительно COM. Значительное их число сводилось к непониманию принципов организации агрегирования и нотификации. И, дабы лишний раз не утруждать себя напрасно, было решено, дать такой развёрнутый ответ с примером и сразу для всех.
Про литературу.
Самой полезной книжкой по технологии COM для меня стала неброская книжонка А.Кобирниченко "Visual Studio 6. Искусство программирования". Для примера два одинаковых понятия из тоже хорошей книжки Елмановой и Трепалина "Delphi 4 технология COM" но несколько путаной:
Apartment:
Елманова: "Можно вызывать методы объекта только из того потока, где объект был создан. При этом одновременно можно создать несколько отличающихся объектов в разных потоках, но каждый объект обязан вызываться только из того потока, где был создан". Кобирниченко: "Каждый объект выполняется в своём потоке. Потоков может быть несколько, но всю синхронизацию берёт на себя сама библиотека. Объект, выполняющийся в одном потоке, ничего не знает о других потоках, поэтому может не заботится о многопоточном доступе к своим методам." Теоретические экскурсы в данной статье, в основном, основаны на книге Кобирниченко.
| Часть первая: Теория. |
Агрегация.
При агрегировании внешний объект не реализует сам интерфейсы имеющиеся у внутреннего. Вместо этого он передаёт своему клиенту указатель указатель непосредственно на интерфейс внутреннего. Клиент напрямую общается с внутренним объектом. Взамен появляются требования к внутреннему объекту связанные с реализацией IUnknown внутреннего объекта. Все вызовы IUnknown внутреннего объекта должны делегироваться методам IUnknown внешнего объекта.
Нотификация.
Помимо методов реализующих входящие интерфейсы вызываемые клиентом, Объект может объявить исходящие интерфейсы, реализация которых возложена на самого клиента.
Исходящие интерфейсы являются расширением принципа уведомления, реализованного в составных документах всё уведомление в которых построено на IAdviseSink с ограниченным набором событий. Установление соединения на основе этого интерфейса требует всего одного вызова IOleObject::SetAdise.
При использовании точек соединения нужно четыре вызова: QueryInterface для получения IConnectionPointContainer, затем FindConnectionPoint для получения нужной точки соединения, затем Advise для передачи указателя на IUnknown исходящего интерфейса и, наконец, QueryInterface со стороны клиента для получения самого исходящего интерфейса. Вся эта деятельность, особенно в случае DCOM, может занять значительное время. Собственно по этому сама Microsoft рекомендует организовывать уведомление на основе собственных интерфейсов, похожих на IadviseSink, а не на основе точек соединения.
После такого введения, я думаю, вы уже готовы взять в руки инструмент Исследователя - IDE Delphi. В нашем случае ;).
| Часть вторая: Махровая практика. |
После тщательных поисков по Дельфийскому хелпу в данной предметной области, мною было обнаружено следующее:
"TAggregatedObject is used as part of an aggregate that has a single controlling Iunknown"
И приписка:
"Note: For more information about aggregation, controlling objects, and interfaces, see the Inside OLE, second edition, by Kraig Brockschmidt"
Ну, второе нам сейчас ни к чему, а вот с первым следует ознакомиться поближе.
Итак, вот он:
| TAggregatedObject = class private FController: Pointer; function GetController: IUnknown; protected { IUnknown } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; public constructor Create(Controller: IUnknown); property Controller: IUnknown read GetController; end; constructor TAggregatedObject.Create(Controller: IUnknown); begin FController := Pointer(Controller); end; function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; begin Result := IUnknown(FController).QueryInterface(IID, Obj); end; |
Теперь следующая проблема. Если мы хотим организовывать нашу библиотеку на основе TAutoObject (а нам этого очень хочется, так как по жизни мы ленивы), то, нам следует каким-то образом заставить его воспринимать наш агрегируемый объект. Способ единственный - перекрытие метода TAutoObject::QueryInterface и собственная реализация данного метода. Проблема в том, что понятие полиморфизма к интерфейсным методам неприменимо и вызываемый метод зависит только от типа ссылки на класс.
В ATL эта проблема решается применением шаблонов классов. В результате чего получается, что все методы реализованные в шаблоне _как_бы_ виртуальные. Это здорово придумано, берёшь любой метод, перекрываешь его и никаких гвоздей. Только надо учитывать, что после сборки, на этане выполнения, никакие фокусы с полиморфными вызовами у вас не пройдут.
Однако, вернёмся к нашим баранам. Просматривая, в некотором унынии, предков нашего обожаемого TAutoObject была обнаружена следующая забавная конструкция:
| TComObject = class(TObject, IUnknown, ISupportErrorInfo) .. protected { IUnknown } function IUnknown.QueryInterface = ObjQueryInterface; .. function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; .. public function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; .. end; |
Ну, думаю, с этим моментом также всё ясно, перекрываем ObjQueryInterface и дело в шляпе. Пошли дальше.
Нотификация:
Каждый школьник знает, что приём и передача нотификационных сообщений в COM производится через интерфейс IconnectionPointContainer. Дочитав MSDN до этого места, большинство программеров, тут же всё бросают и начинают реализовывать свою нотификацию на основе этого интерфейса. Но мы не так наивны, мы пойдём другим путём. На самом деле, реализовать собственную нотификацию, гораздо проще, чем это можно подумать. Работает как во внутренних, так и в локальных серверах, а заодно и в удалённых. Впрочем последнее лично не проверял.
Идея: см. IAdviseSink, и мой пример по его мотивам.
Ну вот, теперь настало время которого вы так долго ждали, рассмотрим пример.
Пример.
Пример представляет из себя два проекта в одной группе. Внутренний сервер и клиент к нему. Для тех кто начал только отсюда напоминаю: Сервер надлежит регистрировать.
Обычно для таких примеров выбирают что-нибудь абсолютно бесполезное. Я же, бесполезные вещи перестал писать одновременно с окончанием института, совпало так. Посему надлежит сделать что-нибудь полезное, но простое. Полезное, потому как смотри выше, а простое, потому как денег мне за это не платят. Пускай это будет таймер, а что, вещь в хозяйстве необходимая, редко какое приложение обходится без таймера. Полагаю, будет вполне естественно назвать его XTimer. Сказано, сделано. Отныне, я надеюсь, вы навсегда забудете где у вас находиться таймер на палитре компонентов и будете пользоваться только моим Aggregated XTimer.
Далее, наш, во всех отношения полезный XTimer надо использовать как-то полезно. Для чего полезно можно использовать таймер? Правильно, для анимации.
Что так же было реализовано. Картинка для анимации взята из SDK DirectX7.
И последнее: в данном примере вы ни найдете ни одного комментария, так как комментировать там особо и нечего. Само документируемый код в чистом виде ;-). Также надеюсь у вас не возникнет впечатления, что использовано слишком много компонент.
Засим всё.
Скачать проект : ( 112.8 K)
Два простых способа уведомления.
| Раздел Подземелье Магов | Алексей Еремеев , дата публикации 14 декабря 2000 |
В своей работе мне частенько приходиться делать разного рода клиент-серверные системы.
И совсем не обязательно на уровне глобальных сетей. Речь пойдет о внутренних подсистемах.
Например, имеем компонент, который эмулирует секундомер. Запустили его с параметром типа "а напомни мне, что будет полночь" и забыли. Ну и конечно событие есть типа OnAlert. И обработчик его честно будет вызван по достижении нужной нам полуночи. Но обработчик один, а захотели узнать об этом событии сразу десять разных объектов. Не вешать же десять будильников?
Конечно, проще в одном обработчике перебрать методы уведомления этих десяти объектов да и дело с концом. Но можно поступить хитрее - заставить объект-будильник самому напоминать всем кто попросит его об этом. Вот о способах такого уведомления и пойдет речь.
Как условие - объект "сервер" ничего не знает об объекте "клиенте". После некоторого размышления и перебрав несколько вариантов я пришел к выводу, что наиболее приемлимые для практики есть два способа. Первый подсмотрен в WinAPI а второй - чисто Дельфи. Оба способа основаны на простой идее регистрации клиента на сервере и оповещении сервером клиентов по внутреннему списку зарегистрированных клиентов.
Способ 1. Оповещение через механизм сообщений Windows.
в модуле объекта-сервера в интерфейсной части определяется пользовательский номер события: const WM_NOTIFY_MSG = WM_USER + 123; в объекте-сервере реализуются две интерфейсные процедуры (вкупе с объявленным в приватной секции и созданным в конструкторе TList, в деструкторе не забудем его разрушить, естественно) procedure RegisterHandle(HW: THandle); var i: integer; begin i := FWindList.IndexOf(pointer(HW)); if i < 0 then FWinList.Add(pointer(HW)); end; procedure UnregisterHandle(HW: THandle) var i: integer; begin i := FWindList.IndexOf(pointer(HW)); if i >= 0 then FWinList.Delete(i); end; и создается функция оповещения в приватной секции: procedure SendNotify(wParam, lParam: integer); var i: integer; begin i := 0; while i < FWinList.Count do begin SendMessage(integer(FWinList.Items[i]), WM_NOTIFY_MSG, wParam, lParam); Inc(i); end; end; можно вместо SendMessage использовать PostMessage, будет асинхронное сообщение, иногда это выгодней, например для исключения возможности бесконечной рекурсии.
Объект- клиент должен иметь хэндл окна, который регистрируется на объекте-сервере и обработчик событий этого окна, который будет вызыватся при оповещении сервером списка клиентов (окон).
У объекта-клиента можно поступить двояко. Если объект-клиент уже имеет хэндл окна (например, форма) то пишется обработчик фиксированного номера события: procedure ServMsg(var Msg: TMessage); message WM_NOTIFY_MSG; или если окна нет, то создается универсальный метод-обработчик и невидимое окно при помощи функции AllocateHWND() (пример смотрите в исходниках VCL - объект TTimer)
Прелесть этого метода состоит в том, что объект-клиент может быть вообще в другом приложении, нежели объект-сервер, и такой трюк пройдет при использовании DLL. Кроме того передавать можно не только пару цифр, но и блоки данных (и даже строки) при помощи сообщения WM_COPYDATA.
Но это уже другая история, а мы пока пойдем дальше.
Способ 2. Оповещение через объект-посредник.
В отдельном модуле создаем объект-посредник, который имеет один метод типа SendEvent и одну ссылку на обработчик события OnEvent. Я назвал такой объект TSynaps (да простят меня нейрохирурги) unit Synaps; interface uses Windows, Messages, SysUtils, Classes; type TSynaps = class(TObject) private FOnEvent : TNotifyEvent; public procedure SendEvent; property OnEvent : TNotifyEvent read FOnEvent write FOnEvent; end; implementation procedure SendEvent; begin if Assigned(FOnEvent) then try FOnEvent(Self); except end; end; end; Причем методов и событий может быть много разных на любой вкус. С очередями, асинхронными "прослойками", задержками и другими наворотами. Тут уж кто на что горазд. Я лишь демонстрирую идею. Модуль с объектом-сервером и модуль с объектом-клиентом имеют право знать о модуле Synaps. В объекте-сервере реализуются уже знакомые нам три функции (чуть иначе):
в интерфейсе объекта: procedure RegisterSynaps(Syn: TSynaps); var i: integer; begin i := FSynapsList.IndexOf(pointer(Syn)); if i < 0 then FSynapsList.Add(pointer(Syn)); end; procedure UnregisterSynaps(Syn: TSynaps); var i: integer; begin i := FSynapsList.IndexOf(pointer(Syn)); if i >= 0 then FSynapsList.Delete(i); end; и приватная функция: procedure NotifySynapses; var i: integer; begin i := 0; while i < FSynapsList.Count do begin TSynaps(FSynapsList.Items[i]).SendEvent; Inc(i); end; end; Объект-клиент создает в себе объект-синапс, назначает его событию OnEvent свой внутренний обработчик и регистрирует этот синапс на объекте-сервере. Вуаля! И получает оттуда уведомления. Кстати, в деструктор синапса можно встроить вызов события OnDestroy, и тогда объект-сервер, при регистрации клиента, может назначить ему обработчик и автоматически разрегистрировать его при уничтожении. Но это уже навороты.
Такой подход позволяет строить обратные вызовы любой сложности. К тому-же это чистый паскаль-код без привязки к операционке. (а вдруг Kylix :о)
Итог.
Как вы могли заметить, оба способа базируются на двух базовых идеях. Первое - это регистрация клиента на сервере, и второе - вызов сервером некой функции внутри клиента. Разница только в механизмах. И выбирать тут можно исходя из вкусов, предпочтений и неких требований, связанных с ресурсоемкостью, переносимостью и т. п.
На самом деле есть очень широко распространенный и давно известный метод под названием CallBack-функция.
Мы вызываем кого-то и передаем как один из параметров адрес другой функции. И этот метод частенько используется в WinAPI (смотрите, к примеру, справку по функции EnumFonts). Но! Механизм прямого CallBack-а довольно некрасиво ложится на объектную модель Дельфи, так что я не стал описывать его здесь. Тем более, что оба способа - то-же самое, но красивше. И самое последнее - не забывайте разрегистрировать клиента в конце работы и освобождать ресурсы в деструкторе. И да известят вас ваши сервера только о хорошем!
Алексей Еремеев
монитор ошибок должна работать как
| Искусство управления ошибками. |
| Раздел Подземелье Магов Часть I : |
Автор: Даутов Ильдар, дата публикации 05 января 2000 |
Продолжая тему "Управление ошибками в Delphi", поставим следующие задачи :
Монитор ошибок
Оформить программу как сервис Windows NT (Win32 service) не составляет большого труда :
ErrorMonitorService.exe /install
Удаление сервиса :
ErrorMonitorService.exe /uninstall
Запуск сервиса выполняется из командной строки следующим образом :
net start ErrorMonitor
Останов сервиса :
net stop ErrorMonitor
Оформив эту последовательность команд как BAT-файл, можно значительно облегчить себе жизнь при отладке сервиса.
Достаточно подробную информацию о сервисах Windows NT можно найти в книге : А.В.Фролов, Г.В.Фролов 'Программирование для Windows NT (часть вторая)', Москва, ДИАЛОГ-МИФИ, 1997
Для сохранения протокола (журнала) пользовательских ошибок используем следующую схему :
Окно просмотра ошибок
Текст программы окна просмотра ошибок приведен ниже : unit fErrorMonitorMessage; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ScktComp; type TfmErrorMonitorMessage = class(TForm) // протокол текущих ошибок meErrorTextNow: TMemo; meJournals: TMemo; // таймер для опроса канала Timer: TTimer; paJournals: TPanel; buJournals: TButton; lbJournals: TListBox; laJournals: TLabel; procedure FormCreate(Sender: TObject); procedure TimerTimer(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure buJournalsClick(Sender: TObject); private public end; // сетевой разделяемый ресурс, где сохраняются журналы // (укажите здесь имя своего ресурса и обеспечьте права для доступа) const LogDir='\\MyServer\C$\Log\'; var fmErrorMonitorMessage: TfmErrorMonitorMessage; h : THandle; // handle Mailslot-канала str : string[250]; // буфер обмена MsgNumber,MsgNext,Read : DWORD; implementation {$R *.DFM} procedure TfmErrorMonitorMessage.FormCreate(Sender: TObject); var sr : TSearchRec; i : integer; begin // создание Mailslot-канала с именем EMonMess // по этому каналу будем получать сообщения об ошибках от сервиса NT h:=CreateMailSlot('\\.\mailslot\EMonMess',0,MAILSLOT_WAIT_FOREVER,nil); if h=INVALID_HANDLE_VALUE then begin ShowMessage('Ошибка создания канала !'); Halt; end; // интервал опроса канала Mailslot - 3 секунды Timer.Interval:=3000; // таймер первоначально был выключен Timer.Enabled:=True; // заполнение списка доступных журналов i:=FindFirst(LogDir+'*.log',faAnyFile,sr); while i = 0 do begin lbJournals.Items.Add(sr.Name); i:=FindNext(sr); end; lbJournals.ItemIndex:=lbJournals.Items.Count-1; FindClose(sr); end; procedure TfmErrorMonitorMessage.TimerTimer(Sender: TObject); var str : string[250]; begin Timer.Enabled:=False; // определение наличия сообщения в канале if not GetMailSlotInfo(h,nil,DWORD(MsgNext),@MsgNumber,nil) then begin ShowMessage('Ошибка сбора информации !'); Close; end; if MsgNext <> MAILSLOT_NO_MESSAGE then begin beep; // чтение сообщения из канала и добавление в текст протокола if ReadFile(h,str,200,DWORD(Read),nil) then meErrorTextNow.Lines.Add(str) else ShowMessage('Ошибка чтения сообщения !'); end; Timer.Enabled:=True; end; procedure TfmErrorMonitorMessage.FormClose(Sender: TObject; var Action: TCloseAction); begin CloseHandle(h); end; procedure TfmErrorMonitorMessage.buJournalsClick(Sender: TObject); var Journal : TFileStream; s : string; begin // получение журнала ошибок за дату meJournals.Lines.Clear; meJournals.Lines.Add('Файл журнала '+lbJournals.Items[lbJournals.ItemIndex]); Journal:=TFileStream.Create(LogDir+lbJournals.Items[lbJournals.ItemIndex], fmOpenRead or fmShareDenyNone); SetLength(s,Journal.Size); Journal.Read(PChar(s)^,Journal.Size); meJournals.Lines.Add(s); Journal.Free; end; end.
Ильдар Даутов
| |
Еще раз о звуке. II
| й Козлов, дата публикации 12 августа 2003г. |
От воды утекло с тех пор, как вышла . Теперь, как и было обещано, статья про микшер. Сразу предупреждаю, что я не приведу ни одной строчки кода. Так что скучная статья получилась. Может, вы вообще зря ее читаете:)?... Нет? Ну тогда начнем.
Ранее мы разобрались с выводом звука. Сегодня мы рассмотрим другую тему: работа с микшером. Эта тема в материалах Королевства освещена в меньшей степени ;) поэтому остановимся на ней более подробно, местами цитируя MSDN.
Как говорил К.Маркс ( может кто помнит про такого) хороший архитектор отличается от пчелы тем, что при строительстве имеет план на бумаге ( или хотя бы в голове). Пчела же плана не имеет, у нее инстинкт. Я пока не слышал, есть ли инстинкт программирования, возможно, через несколько поколений программистов он и появится у отдельных личностей, но пока для работы нужен план. Поэтому сначала построим модель в голове, о!
Еще раз о звуке
| Раздел Подземелье Магов | й Козлов, дата публикации 04 марта 2002г. |
От ого стола):
Итак, на что я попытаюсь ответить:
Чего я не скажу (надеюсь, скажет кто-то другой :)
Еще "на берегу" хочу договориться -- HELP или MSDN не переписываю! В хелпах Delphi все функции описаны -- осталось только найти…
Начинаем.
Для нас важны следующие понятия: PCM, выборка, битовое разрешение, частота выборки. (см. более полно )
PCM (импульсно-кодовая модуляция) -- Звук может быть представлен разными способами, но это самый простой (и, наверное, поэтому наиболее используемый). Что это такое, можно посмотреть я повторяться не буду.
Sample (выборка) -- значение амплитуды дискретизированного сигнала. Секунда звучания на компакт-диске содержит 44100 выборок (сэмплов). Имеется в виду, что выборка содержит в себе реально два значения - для левого и правого каналов.
sample rate (частота выборки) -- Число выборок в секунду, которое используется для записи звука. Более высокие частоты соответствуют более высокому качеству звука, однако потребляют большее количество памяти.
sample size (битовое разрешение) -- определяет количество бит, используемое для записи единичной выборки на каждом канале. Компьютеры используют в основном 8 и 16 бит, профессиональное оборудование - 18, 20 и выше.
Несколько слов по поводу "железа". Необходимо четко различать, что звуковая плата -- это НЕ ОДНО устройство в системе. Есть устройство вывода звука, записи звука, микшер, синтезатор и т.д. по вкусу. Это важно понимать, т.к. каждое устройство имеет свой набор функций: waveOut***, waveIn***, midiOut***, midiIn***, mixer*** и др.
Еще раз повторю: все это РЕАЛЬНО РАЗНЫЕ устройства, упакованные в одном или нескольких аудиочипах. Кому интересно, посмотрите описание любого аудиочипа. Например, или
Как узнать, есть ли устройство вывода/записи звука
Для ответа на этот важнейший вопрос ( если устройства нет -- мы ведь ничего не услышим, правда?) используются следующие функции и структуры API:
Если Вы знаете, что устройство в системе одно, можно поступить так:
procedure TForm1.btnClick(Sender: TObject); var WOutCaps : TWAVEOUTCAPS; begin // проверка наличия устройства вывода FillChar(WOutCaps,SizeOf(TWAVEOUTCAPS),#0); if MMSYSERR_NOERROR <> WaveOutGetDevCaps(0,@WOutCaps,SizeOf(TWAVEOUTCAPS)) then begin ShowMessage('Ошибка аудиоустройства'); exit; end; end;
Так мы пытаемся узнать характеристики устройства с номером 0 (т.е. первого в системе) и если его нет, говорим об ошибке. Если у нас несколько звуковых карточек, используем waveOutGetNumDevs. Характеристики нам понадобятся позже.
Важно: если хотим узнать, есть ли устройство записи, миксер в системе, используем WaveIn***, mixer*** и т.д. Ведь этих устройств может и не быть (USB-колонки). Так что вопрос: "Есть ли звуковая карточка в компьютере?" не совсем корректен для наших целей, да и не нужен. Вам звук выводить или карточкой хвалиться?
Как использовать Multimedia API для записи/вывода звука.
Для вывода звука мы используем следующий набор функций и структур API:
Как же мы выведем звук?
Во-первых, надо озаботиться способом общения с драйвером. Вариантов много: сообщения, callback-функции, объекты-события и т.д. По моему опыту, наиболее "приятно" работать с объектами-событиями, то есть использовать объекты ядра Events и потоки. Работает без особых проблем, лего управляется, нет ненужных задержек в очереди сообщений, можно поставить более высокий приоритет потоку, обрабатывающему звуковые данные. В общем, плюсов много, а главное … Microsoft рекомендует.
Так, с этим определились, теперь формат звуковых данных. Необходимо заполнить TWAVEFORMATEX, например, так:
var wfx : TWAVEFORMATEX; … // заполнение структуры формата FillChar(wfx,Sizeof(TWAVEFORMATEX),#0); with wfx do begin wFormatTag := WAVE_FORMAT_PCM; // используется PCM формат nChannels := 2; // это стереосигнал nSamplesPerSec := 44100; // частота дискретизации 44,1 Кгц wBitsPerSample := 16; // битовое разрешение выборки 16 бит nBlockAlign := wBitsPerSample div 8 * nChannels; // число байт в выборке для стереосигнала -- 4 байта nAvgBytesPerSec := nSamplesPerSec * nBlockAlign; // число байт в секундном интервале для стереосигнала cbSize := 0; // не используется end;
Готово, можно открывать:
var wfx : TWAVEFORMATEX; hEvent : THandle; wfx : TWAVEFORMATEX; hwo : HWAVEOUT; … // открытие устройства hEvent := CreateEvent(nil,false,false,nil); if WaveOutOpen(@hwo,0,@wfx,hEvent,0,CALLBACK_EVENT) <> MMSYSERR_NOERROR then …;
Устройство открыто, теперь (вторым шагом) решим, откуда будем брать данные для вывода. Для этого выделяем память и готовим буферы вывода. Заметьте, готовим ДВА буфера для того, чтобы организовать двойную буферизацию -- и никто никого не ждет…если буфер подходящего размера. В зависимости от производительности системы он может быть поменьше. ( у меня был минимум -- 8 кбайт)
Ниже в листинге есть одна особенность -- выделяется память из расчета на КАЖДЫЙ канал стереозвука -- это нужно для нашего примера, но обычно такое не требуется.
И еще одна особенность -- умные люди (см. ) рекомендуют выделять только целое количество страниц памяти с учетом грануляции, что мы и делаем.
var wfx : TWAVEFORMATEX; hEvent : THandle; wfx : TWAVEFORMATEX; hwo : HWAVEOUT; si : TSYSTEMINFO; wh : array [0..1] of TWAVEHDR; Buf : array [0..1] of PChar; CnlBuf : array [0..1] of PChar; … // выделение памяти под буферы, выравниваются под страницу памяти Windows GetSystemInfo(si); buf[0] := VirtualAlloc(nil,(BlockSize*4+si.dwPageSize-1) div si.dwPagesize * si.dwPageSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE); buf[1] := PChar(LongInt(buf[0]) + BlockSize); // отдельно буферы для генераторов под каждый канал CnlBuf[0] := PChar(LongInt(Buf[1]) + BlockSize); CnlBuf[1] := PChar(LongInt(CnlBuf[0]) + BlockSize div 2); // подготовка 2-х буферов вывода for I:=0 to 1 do begin FillChar(wh[I],sizeof(TWAVEHDR),#0); wh[I].lpData := buf[I]; // указатель на буфер wh[I].dwBufferLength := BlockSize; // длина буфера waveOutPrepareHeader(hwo, @wh[I], sizeof(TWAVEHDR)); // подготовка буферов драйвером end;
Итак, куда выводить -- есть, откуда выводить -- есть. Третим шагом осталось определить, что выводить и СДЕЛАТЬ ЭТО (вывести звук). Сначала мы генерим данные для левого и правого канала раздельно, затем смешиваем и помещаем в первый буфер вывода. Генерация производится очень просто -- sin. Смешиваем два буфера в один с помощью процедуры mix -- небольшая процедурка на ASMе Такой подход я избрал вот почему -- не все же синус по двум каналам генерить! Можно и музыку разную налево и направо пустить. (это называется бинуральное слушание, кажется). Заметьте, для генерации каждого нового буфера мы сохраняем текущее время сигнала, чтобы он был гладкий да шелковистый... И ПОМНИТЕ, что все это делается в отдельном потоке. Как видите, здесь есть пространство для творчества (оптимизации), но это оставляю читателям.
// генерация буферов каналов Generator(CnlBuf[0],Typ[0], Freq[0], Lev[0], BlockSize div 2, tPred[0]); Generator(CnlBuf[1],Typ[1], Freq[1], Lev[1], BlockSize div 2, tPred[1]); // смешивание буферов каналов в первый буфер вывода Mix(buf[0],CnlBuf[0],CnlBuf[1], BlockSize div 2);
И наконец, вот он, ЗВУК!
I:=0; while not Terminated do begin // передача очередного буфера драйверу для проигрывания waveOutWrite(hwo, @wh[I], sizeof(WAVEHDR)); WaitForSingleObject(hEvent, INFINITE); I:= I xor 1; // генерация буферов каналов Generator(CnlBuf[0],Typ[0], Freq[0], Lev[0], BlockSize div 2, tPred[0]); Generator(CnlBuf[1],Typ[1], Freq[1], Lev[1], BlockSize div 2, tPred[1]); // смешивание буферов каналов в очередной буфер вывода Mix(buf[I],CnlBuf[0],CnlBuf[1], BlockSize div 2); // ожидание конца проигрывания и освобождения предыдущего буфера end;
Важно: нет необходимости повторно готовить буферы функцией waveOutPrepareHeader, просто пишите данные в память и играйте… Когда Вы насладитесь звуком (все это пищание надоест), нужно выключить машинку:
// завершение работы с аудиоустройством waveOutReset(hwo); waveOutUnprepareHeader(hwo, @wh[0], sizeof(WAVEHDR)); waveOutUnprepareHeader(hwo, @wh[1], sizeof(WAVEHDR)); // освобождение памяти VirtualFree(buf[0],0,MEM_RELEASE); WaveOutClose(hwo);
И освобождаем наш объект-событие.
CloseHandle(hEvent);
Все, наступила тишина…
Итак, мы разобрались с тремя вопросами:
Далее по плану: как менять громкость и вообще работать с микшером и что такое fullduplex.
Пример программы подготовлен для Delphi5. Скачать — 5.8K
Литература
Гордеев О. В. Программирование звука в Windows. СПб.: БХВ — Санкт-Петербург 1999 384 с.
Сергей Козлов
Специально для
Файловые операции средствами ShellAPI.
| Раздел Подземелье Магов | Автор: Владимир Татарчевский дата публикации 15 октября 1999 г. |
В данной статье мы подробно рассмотрим применение функции SHFileOperation. function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall; Данная функция позволяет производить копирование, перемещение, переименование и удаление (в том числе и в Recycle Bin) объектов файловой системы.
Функция возвращает 0, если операция выполнена успешно, и ненулевое значение в противном :-) случае.
Функция имеет единственный аргумент - структуру типа TSHFileOpStruct, в которой и передаются все необходимые данные.
Эта структура выглядит следующим образом: _SHFILEOPSTRUCTA = packed record Wnd: HWND; wFunc: UINT; pFrom: PAnsiChar; pTo: PAnsiChar; fFlags: FILEOP_FLAGS; fAnyOperationsAborted: BOOL; hNameMappings: Pointer; lpszProgressTitle: PAnsiChar; { используется только при установленном флаге FOF_SIMPLEPROGRESS } end; Поля этой структуры имеют следующее назначение:
hwnd Хэндл окна, на которое будут выводиться диалоговые окна о ходе операции.
wFunc Требуемая операция. Может принимать одно из значений:
Указатель на буфер, содержащий пути к одному или нескольким файлам. Если файлов несколько, между путями ставится нулевой байт. Список должен заканчиваться двумя нулевыми байтами.
pTo
Аналогично pFrom, но содержит путь к директории - адресату, в которую производится копирование или перемещение файлов. Также может содержать несколько путей. При этом нужно установить флаг FOF_MULTIDESTFILES.
fFlags
Управляющие флаги.
Принимает значение TRUE если пользователь прервал любую файловую операцию до ее завершения и FALSE в ином случае.
hNameMappings
Дескриптор объекта отображения имени файла, который содержит массив структур SHNAMEMAPPING. Каждая структура содержит старые и новые имена пути для каждого файла, который перемещался, скопирован, или переименован. Этот элемент используется только, если установлен флаг FOF_WANTMAPPINGHANDLE.
lpszProgressTitle
Указатель на строку, используемую как заголовок для диалогового окна прогресса. Этот элемент используется только, если установлен флаг FOF_SIMPLEPROGRESS.
Примечание.
Если pFrom или pTo не указаны, берутся файлы из текущей директории. Текущую директорию можно установить с помощью функции SetCurrentDirectory и получить функцией GetCurrentDirectory.
Форма просмотра журнала сбоев
Рисунок 1
Здесь показан внешний вид формы для просмотра журнала сбоев; думаю, комментарии не требуются. Отмечу лишь, что эта форма (наряду с другими формами общего назначения) лежит в DLL, и мне не приходится «таскать» её из проекта в проект. В целом процесс кодирования обработки ИС в каждом моём проекте выглядит так:
{ AskShowForm(AF_EXCEPTION_LOG); }
Формат CRON
Для задания моментов срабатывания синхронизированного таймера используется формат CRON (юниксоиды в курсе - это демон регулярно выполняемых заданий). Идея простого способа записи в строковой форме периодических событий любой сложности, привязанных к астрономическому времени, пришлась очень кстати. Здесь используется модифицированный формат CRON (добавлены секунды, расширены правила определения списков).Строка CRON представляет собой несколько , разделенных пробелом. Каждый список задает перечень моментов времени или даты, в единицах, зависящих от позиции (номера) списка в строке.
Последовательность списков в строке CRON такова: Секунды Минуты Часы Дни Месяцы ДниНедели
Если какая-либо единица времени/даты имеет произвольное значение, то ее просто опускают (если все старшие единицы тоже произвольны) или список ее значений представляют знаком "*" (если соседняя старшая единица задана).
Примеры записи периодических событий в формате CRON (с вариантами):
| 0,30 0+30 +30 | |
| 0-59 0-59 0-16+8 * * 0+8 * * +8 | |
| 0 0 1-11,13-23 | |
| 0-59+3 * * 1 +3 * * 1 | |
| 0 30 * * * 0 |
| й, дата публикации 25 августа 2003г. |
Существует определенный класс программ, для которых достаточно важным является размер. Как правило, это утилиты с ограниченной функциональностью, и при их написании аничиваются использованием модулей Windows и Messages. Однако, при этом нередко хотелось бы иметь полноценный сервис обработки исключений, не утяжеляя проект модулем SysUtils. Попробуем решить эту задачу.
В Delphi работа с исключениями разделена на две части: собственно механизм генерации и обработки, расположенный в модуле System, и набор сервисных функций и классов, находящийся в SysUtils.
Реализация механизма в System сама по себе представляет немалый интерес, но ее рассмотрение выходит за рамки данной статьи. Нас интересует только небольшая ее часть, а именно процедура _ExceptionHandler. Это обработчик исключений, установленный при старте приложения, и получающий управление при генерации системой исключения – например, при вызове приложением функции RaiseException. _ExceptionHandler проводит ряд проверок, в зависимости от которых предпринимаются различные действия. Кратко рассмотрим только некоторые из них:
Таким образом, нас интересуют две переменные: ExceptObjProc и ExceptProc. Заглянем в SysUtils, чтобы посмотреть, как они используются в нем. В секции инициализации этот модуль присваивает им адреса функции GetExceptionObject и процедуры ExceptHandler соответственно. Первая из них пытается подобрать по коду ошибки соответствующий класс исключения и, при удаче, возвращает его экземрляр. Вторая производит нотификацию пользователя, используя строку сообщения из объекта, и вызывает Halt с кодом 1.
Итак, нам требуется просто присвоить адреса собственных обработчиков этим переменным и мы получим достаточный сервис по работе с исключениями, причем обязательным является только аналог ExceptHandler. Этим и займемся.
Прежде всего, нам необходим базовый класс исключения, по аналогии с Exception из SysUtils. Ниже приводится один из возможных вариантов его реализации:
| interface uses Windows; type TLogHandler = procedure (ExceptObject: TObject; ExceptAddr: Pointer); LException = class private FExceptAddress: Pointer; protected function GetExceptionMessage: string; virtual; abstract; function GetExceptionTitle: string; virtual; property ExceptionAddress: Pointer read FExceptAddress; procedure ShowException; virtual; public property ExceptionMessage: string read GetExceptionMessage; property ExceptionTitle: string read GetExceptionTitle; function GetAddrString: string; end; var LogHandler: TLogHandler = nil; implementation { LException } function LException.GetAddrString: string; const CharBuf: array[0..15] of Char = '0123456789ABCDEF'; var BufLen: integer; Value: Cardinal; begin BufLen:=Succ(SizeOf(FExceptAddress) shl 1); SetLength(Result, BufLen); Result[1]:='$'; Value:=Cardinal(FExceptAddress); while BufLen > 1 do begin Result[BufLen]:=CharBuf[Value and $F]; Value:=Value shr 4; Dec(BufLen); end; end; function LException.GetExceptionTitle: string; begin Result:='Error'; end; procedure LException.ShowException; begin MessageBox(0, PChar(ExceptionMessage), PChar(ExceptionTitle), MB_ICONERROR or MB_TASKMODAL); end; |
Раз уж мы внедряемся в обработку исключений, то почему бы не предусмотреть заодно и механизм ведения лога ошибок? Для этого и предусмотрен тип TLogHandler и переменная LogHandler. Остальной код прост и вряд ли нуждается в комментариях.
Далее, нам необходимо описать наш обработчик и присвоить его адрес переменной:
| type TExceptHandler = TLogHandler; var OldHandler: TExceptHandler; procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); begin if Assigned(LogHandler) then try LogHandler(ExceptObject, ExceptAddr); except end; if ExceptObject is LException then begin LException(ExceptObject).FExceptAddress:=ExceptAddr; LException(ExceptObject).ShowException; Halt(1); end else if Assigned(OldHandler) then OldHandler(ExceptObject, ExceptAddr); end; procedure InitProc; begin OldHandler:=TExceptHandler(ExceptProc); ExceptProc:=@ExceptHandler; end; procedure FinalProc; begin TExceptHandler(ExceptProc):=OldHandler; end; initialization InitProc; finalization FinalProc; |
Аналог GetExceptionObject требуется реже и его реализация не представляет какой-либо сложности, поэтому я оставляю это читателям.
В качестве примера рассмотрим вариант реализации класса исключения для консольного приложения:
| type LConsoleException = class(LException) private FMsg: string; protected function GetExceptionMessage: string; override; procedure ShowException; override; public constructor Create(Msg: string); end; { EConsoleException } constructor LConsoleException.Create(Msg: string); begin FMsg:=Msg; end; function LConsoleException.GetExceptionMessage: string; begin Result:=ExceptionTitle + ': ' + FMsg + ' at address ' + GetAddrString + #13#10; end; procedure LConsoleException.ShowException; var s: string; Len: DWORD; H: THandle; begin s:=ExceptionMessage; Len:=Length(s); H:=GetStdHandle(STD_ERROR_HANDLE); if H <> INVALID_HANDLE_VALUE then begin WriteConsole(H, PChar(s), Len, Len, nil); CloseHandle(H); end else inherited; end; |
В заключении хочу отметить, что рассмотренный пример актуален для узкого класса приложений. Использование модулей SysUtils и Forms вносит в работу с исключениями весьма существенные коррективы.
Набережных Сергей
25 августа 2003г.
obal.pas
Unit Global; Interface CONST //MapInfo STANDARD Definitions''''''''''''''''''''''''' //''' Angle conversion '''''''''''''''''''''''''''''''''''''''''''''''''''''''' DEG_2_RAD = 0.01745329252; RAD_2_DEG = 57.29577951; //''' COLOR Consts ''''''''''''''''''''''''''''''''''''''''''''''''''''' miBLACK = '0'; miWHITE = '16777215'; miRED = '16711680'; miGREEN = '65280'; miBLUE = '255'; miCYAN = '65535'; miMAGENTA = '16711935'; miYELLOW = '16776960'; //''' TableInfo() Consts ''''''''''''''''''''''''''''''''''''''''''''''''''''' TAB_INFO_NAME = '1'; TAB_INFO_NUM = '2'; TAB_INFO_TYPE = '3'; TAB_INFO_NCOLS = '4'; TAB_INFO_MAPPABLE = '5'; TAB_INFO_READONLY = '6'; TAB_INFO_TEMP = '7'; TAB_INFO_NROWS = '8'; TAB_INFO_EDITED = '9'; TAB_INFO_FASTEDIT = '10'; TAB_INFO_UNDO = '11'; TAB_INFO_MAPPABLE_TABLE = '12'; TAB_INFO_USERMAP = '13'; TAB_INFO_USERBROWSE = '14'; TAB_INFO_USERCLOSE = '15'; TAB_INFO_USEREDITABLE = '16'; TAB_INFO_USERREMOVEMAP = '17'; TAB_INFO_USERDISPLAYMAP = '18'; TAB_INFO_TABFILE = '19'; TAB_INFO_MINX = '20'; TAB_INFO_MINY = '21'; TAB_INFO_MAXX = '22'; TAB_INFO_MAXY = '23'; TAB_INFO_SEAMLESS = '24'; TAB_INFO_COORDSYS_MINX = '25'; TAB_INFO_COORDSYS_MINY = '26'; TAB_INFO_COORDSYS_MAXX = '27'; TAB_INFO_COORDSYS_MAXY = '28'; TAB_INFO_COORDSYS_CLAUSE = '29'; TAB_INFO_COORDSYS_NAME = '30'; TAB_INFO_NREFS = '31'; //''' Table type Consts, returned by TableInfo(, TAB_INFO_TYPE) ''''' TAB_TYPE_BASE = '1'; TAB_TYPE_RESULT = '2'; TAB_TYPE_VIEW = '3'; TAB_TYPE_IMAGE = '4'; //''' ColumnInfo() Consts '''''''''''''''''''''''''''''''''''''''''''''''''''' COL_INFO_NAME = '1'; COL_INFO_NUM = '2'; COL_INFO_TYPE = '3'; COL_INFO_WIDTH = '4'; COL_INFO_DECPLACES = '5'; COL_INFO_INDEXED = '6'; COL_INFO_EDITABLE = '7'; //''' Column type Consts, returned by ColumnInfo(, COL_INFO_TYPE) ''' COL_TYPE_CHAR = '1'; COL_TYPE_DECIMAL = '2'; COL_TYPE_INTEGER = '3'; COL_TYPE_SMALLINT = '4'; COL_TYPE_DATE = '5'; COL_TYPE_LOGICAL = '6'; COL_TYPE_GRAPHIC = '7'; COL_TYPE_FLOAT = '8'; //''' WindowInfo() Consts '''''''''''''''''''''''''''''''''''''''''''''''''''' WIN_INFO_NAME = '1'; WIN_INFO_TYPE = '3'; WIN_INFO_WIDTH = '4'; WIN_INFO_HEIGHT = '5'; WIN_INFO_X = '6'; WIN_INFO_Y = '7'; WIN_INFO_TOPMOST = '8'; WIN_INFO_STATE = '9'; WIN_INFO_TABLE = '10'; WIN_INFO_OPEN = '11'; WIN_INFO_WND = '12'; //''' Window types, returned by WindowInfo(, WIN_INFO_TYPE) ''''''''''' WIN_MAPPER = '1'; WIN_BROWSER = '2'; WIN_LAYOUT = '3'; WIN_GRAPH = '4'; WIN_HELP = '1001'; WIN_MAPBASIC = '1002'; WIN_MESSAGE = '1003'; WIN_RULER = '1007'; WIN_INFO = '1008'; WIN_LEGEND = '1009'; WIN_STATISTICS = '1010'; WIN_MAPINFO = '1011'; //''' Version 2 window types no longer used in version 3 '''''''''''''''''''''' WIN_TOOLPICKER = '1004'; WIN_PENPICKER = '1005'; WIN_SYMBOLPICKER = '1006'; //''' Window states, returned by WindowInfo(, WIN_INFO_STATE) ''''''''' WIN_STATE_NORMAL = '0'; WIN_STATE_MINIMIZED = '1'; WIN_STATE_MAXIMIZED = '2'; //''' FileAttr() Consts and return codes ''''''''''''''''''''''''''''''''''''' FILE_ATTR_MODE = '1'; MODE_INPUT = '0'; MODE_OUTPUT = '1'; MODE_APPEND = '2'; MODE_RANDOM = '3'; MODE_BINARY = '4'; //''' ObjectInfo() Consts '''''''''''''''''''''''''''''''''''''''''''''''''''' OBJ_INFO_TYPE = '1'; OBJ_INFO_PEN = '2'; OBJ_INFO_SYMBOL = '2'; OBJ_INFO_TEXTFONT = '2'; OBJ_INFO_BRUSH = '3'; OBJ_INFO_NPNTS = '20'; OBJ_INFO_TEXTSTRING = '3'; OBJ_INFO_SMOOTH = '4'; OBJ_INFO_FRAMEWIN = '4'; OBJ_INFO_NPOLYGONS = '21'; OBJ_INFO_TEXTSPACING = '4'; OBJ_INFO_TEXTJUSTIFY = '5'; OBJ_INFO_FRAMETITLE = '6'; OBJ_INFO_TEXTARROW = '6'; //''' Object types, returned by ObjectInfo(, OBJ_INFO_TYPE) '''''''''''''' OBJ_ARC = '1'; OBJ_ELLIPSE = '2'; OBJ_LINE = '3'; OBJ_PLINE = '4'; OBJ_POINT = '5'; OBJ_FRAME = '6'; OBJ_REGION = '7'; OBJ_RECT = '8'; OBJ_ROUNDRECT = '9'; OBJ_TEXT = '10'; //''' ObjectGeography() Consts ''''''''''''''''''''''''''''''''''''''''''''''' OBJ_GEO_MINX = '1'; OBJ_GEO_LINEBEGX = '1'; OBJ_GEO_POINTX = '1'; OBJ_GEO_MINY = '2'; OBJ_GEO_LINEBEGY = '2'; OBJ_GEO_POINTY = '2'; OBJ_GEO_MAXX = '3'; OBJ_GEO_LINEENDX = '3'; OBJ_GEO_MAXY = '4'; OBJ_GEO_LINEENDY = '4'; OBJ_GEO_ARCBEGANGLE = '5'; OBJ_GEO_TEXTLINEX = '5'; OBJ_GEO_ROUNDRADIUS = '5'; OBJ_GEO_ARCENDANGLE = '6'; OBJ_GEO_TEXTLINEY = '6'; OBJ_GEO_TEXTANGLE = '7'; //''' StyleAttr() Consts ''''''''''''''''''''''''''''''''''''''''''''''''''''' PEN_WIDTH = '1'; PEN_PATTERN = '2'; PEN_COLOR = '4'; BRUSH_PATTERN = '1'; BRUSH_FORECOLOR = '2'; BRUSH_BACKCOLOR = '3'; FONT_NAME = '1'; FONT_STYLE = '2'; FONT_POINTSIZE = '3'; FONT_FORECOLOR = '4'; FONT_BACKCOLOR = '5'; SYMBOL_CODE = '1'; SYMBOL_COLOR = '2'; SYMBOL_POINTSIZE = '3'; //''' MapperInfo() Consts '''''''''''''''''''''''''''''''''''''''''''''''''''' MAPPER_INFO_ZOOM = '1'; MAPPER_INFO_SCALE = '2'; MAPPER_INFO_CENTERX = '3'; MAPPER_INFO_CENTERY = '4'; MAPPER_INFO_MINX = '5'; MAPPER_INFO_MINY = '6'; MAPPER_INFO_MAXX = '7'; MAPPER_INFO_MAXY = '8'; MAPPER_INFO_LAYERS = '9'; MAPPER_INFO_EDIT_LAYER = '10'; MAPPER_INFO_XYUNITS = '11'; MAPPER_INFO_DISTUNITS = '12'; MAPPER_INFO_AREAUNITS = '13'; MAPPER_INFO_SCROLLBARS = '14'; //''' LayerInfo() Consts ''''''''''''''''''''''''''''''''''''''''''''''''''''' LAYER_INFO_NAME = '1'; LAYER_INFO_EDITABLE = '2'; LAYER_INFO_SELECTABLE = '3'; LAYER_INFO_ZOOM_LAYERED = '4'; LAYER_INFO_ZOOM_MIN = '5'; LAYER_INFO_ZOOM_MAX = '6'; LAYER_INFO_COSMETIC = '7'; LAYER_INFO_PATH = '8'; LAYER_INFO_DISPLAY = '9'; LAYER_INFO_OVR_LINE = '10'; LAYER_INFO_OVR_PEN = '11'; LAYER_INFO_OVR_BRUSH = '12'; LAYER_INFO_OVR_SYMBOL = '13'; LAYER_INFO_OVR_FONT = '14'; LAYER_INFO_LBL_EXPR = '15'; LAYER_INFO_LBL_LT = '16'; LAYER_INFO_LBL_CURFONT = '17'; LAYER_INFO_LBL_FONT = '18'; LAYER_INFO_LBL_PARALLEL = '19'; LAYER_INFO_LBL_POS = '20'; LAYER_INFO_ARROWS = '21'; LAYER_INFO_NODES = '22'; LAYER_INFO_CENTROIDS = '23'; LAYER_INFO_TYPE = '24'; //''' Display Modes, returned by LayerInfo() for LAYER_INFO_DISPLAY ''''''''''' LAYER_INFO_DISPLAY_OFF = '0'; LAYER_INFO_DISPLAY_GRAPHIC = '1'; LAYER_INFO_DISPLAY_GLOBAL = '2'; LAYER_INFO_DISPLAY_VALUE = '3'; //''' Label Linetypes, returned by LayerInfo() for LAYER_INFO_LBL_LT '''''''''' LAYER_INFO_LBL_LT_NONE = '0'; LAYER_INFO_LBL_LT_SIMPLE = '1'; LAYER_INFO_LBL_LT_ARROW = '2'; //''' Label Positions, returned by LayerInfo() for LAYER_INFO_LBL_POS ''''''''' LAYER_INFO_LBL_POS_CC = '0'; LAYER_INFO_LBL_POS_TL = '1'; LAYER_INFO_LBL_POS_TC = '2'; LAYER_INFO_LBL_POS_TR = '3'; LAYER_INFO_LBL_POS_CL = '4'; LAYER_INFO_LBL_POS_CR = '5'; LAYER_INFO_LBL_POS_BL = '6'; LAYER_INFO_LBL_POS_BC = '7'; LAYER_INFO_LBL_POS_BR = '8'; //''' Layer Types, returned by LayerInfo() for LAYER_INFO_TYPE '''''''''''''''' LAYER_INFO_TYPE_NORMAL = '0'; LAYER_INFO_TYPE_COSMETIC = '1'; LAYER_INFO_TYPE_IMAGE = '2'; LAYER_INFO_TYPE_THEMATIC = '3'; //''' CommandInfo() Consts ''''''''''''''''''''''''''''''''''''''''''''''''''' CMD_INFO_X = '1'; CMD_INFO_Y = '2'; CMD_INFO_SHIFT = '3'; CMD_INFO_CTRL = '4'; CMD_INFO_X2 = '5'; CMD_INFO_Y2 = '6'; CMD_INFO_TOOLBTN = '7'; CMD_INFO_MENUITEM = '8'; CMD_INFO_WIN = '1'; CMD_INFO_SELTYPE = '1'; CMD_INFO_ROWID = '2'; CMD_INFO_STATUS = '1'; CMD_INFO_MSG = '1000'; CMD_INFO_DLG_OK = '1'; CMD_INFO_DLG_DBL = '1'; CMD_INFO_FIND_RC = '3'; CMD_INFO_FIND_ROWID = '4'; CMD_INFO_XCMD = '1'; //''' SysteMIdetailnfo() Consts '''''''''''''''''''''''''''''''''''''''''''''''''''' SYS_INFO_PLATFORM = '1'; SYS_INFO_APPVERSION = '2'; SYS_INFO_MIVERSION = '3'; SYS_INFO_RUNTIME = '4'; SYS_INFO_CHARSET = '5'; //''' Platform, returned by SysteMIdetailnfo(SYS_INFO_PLATFORM) ''''''''''''''''''''' PLATFORM_WIN = '1'; PLATFORM_MAC = '2'; PLATFORM_MOTIF = '3'; PLATFORM_X11 = '4'; PLATFORM_XOL = '5'; PLATFORM_DWT = '6'; //''' SelectionInfo() Consts ''''''''''''''''''''''''''''''''''''''''''''''''' SEL_INFO_TABLENAME = '1'; SEL_INFO_SELNAME = '2'; SEL_INFO_NROWS = '3'; //''' Return Values from StringCompare(, ) '''''''''''''''''''''' STR_LT = '-1'; STR_GT = '1'; STR_EQ = '0'; //''' Parameters used for IntersectNodes(obj1, obj2, mode) '''''''''''''''''''' INCL_CROSSINGS = '1'; INCL_COMMON = '6'; INCL_ALL = '7'; //''' Macros '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' // CLS = 'print Chr$(12) // MUST BE MANUALLY ENTERED //''' Symbol Styles MAPINFOW.FNT ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' SYM_NULL = '31'; SYM_SQUARE_FILL = '32'; SYM_DIAMOND_FILL = '33'; SYM_CIRCLE_FILL = '34'; SYM_STAR_FILL = '35'; SYM_UP_FILL = '36'; SYM_DOWN_FILL = '37'; SYM_SQUARE = '38'; SYM_DIAMOND = '39'; SYM_CIRCLE = '40'; SYM_STAR = '41'; SYM_UP = '42'; SYM_DOWN = '43'; SYM_SQUARE_SHADOW = '44'; SYM_UP_SHADOW = '45'; SYM_CIRCLE_SHADOW = '46'; SYM_ARROW_NE = '47'; SYM_ARROW_SW = '48'; SYM_CROSS = '49'; SYM_X = '50'; SYM_XCROSS = '51'; SYM_PLANE = '52'; SYM_SCHOOL = '53'; SYM_FLAG = '54'; SYM_HOSPITAL = '55'; SYM_MEDIC = '56'; SYM_CAMPING = '57'; SYM_BOATING = '58'; SYM_BULLEYE = '59'; SYM_HOUSE_WOOD1 = '60'; SYM_INTERSTATE = '61'; SYM_HIGHWAY = '62'; SYM_OILFIELD = '63'; SYM_MINING = '64'; SYM_CHURCH = '65'; SYM_HIRISE = '66'; SYM_PUSHPIN = '67'; //''' Symbol Styles GEO_SYM.FNT ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' SYM_HOUSE_BRICK1 = '68'; SYM_HOUSE_BRICK2 = '69'; SYM_HOUSE_WOOD2 = '70'; SYM_HOUSE_MOBIL = '71'; SYM_BUSINESS = '66'; // //MapInfo MENU Commands'''''''''''''''''''''''' // M_FILE_NEW = '101'; M_FILE_OPEN = '102'; M_FILE_OPEN_ODBC = '116'; M_FILE_ADD_WORKSPACE = '108'; M_FILE_CLOSE = '103'; M_FILE_CLOSE_ALL = '104'; M_FILE_SAVE = '105'; M_FILE_SAVE_COPY_AS = '106'; M_FILE_SAVE_WORKSPACE = '109'; M_FILE_SAVE_WINDOW_AS = '609'; M_FILE_REVERT = '107'; M_FILE_RUN = '110'; M_FILE_PAGE_SETUP = '111'; M_FILE_PRINT = '112'; M_FILE_EXIT = '113'; M_SENDMAIL_CURRENTWINDOW = '114'; M_SENDMAIL_WORKSPACE = '115'; //---------------------------------------------------------------------------- // Edit menu //---------------------------------------------------------------------------- M_EDIT_UNDO = '201'; M_EDIT_CUT = '202'; M_EDIT_COPY = '203'; M_EDIT_PASTE = '204'; M_EDIT_CLEAR = '205'; M_EDIT_CLEAROBJ = '206'; M_EDIT_RESHAPE = '1601'; M_EDIT_NEW_ROW = '702'; M_EDIT_GETINFO = '207'; //---------------------------------------------------------------------------- // Objects menu //---------------------------------------------------------------------------- M_OBJECTS_SET_TARGET = '1610'; M_OBJECTS_CLEAR_TARGET = '1611'; M_OBJECTS_COMBINE = '1605'; M_OBJECTS_SPLIT = '1612'; M_OBJECTS_ERASE = '1613'; M_OBJECTS_ERASE_OUT = '1614'; M_OBJECTS_OVERLAY = '1615'; M_OBJECTS_BUFFER = '1606'; M_OBJECTS_SMOOTH = '1602'; M_OBJECTS_UNSMOOTH = '1603'; M_OBJECTS_CVT_PGON = '1607'; M_OBJECTS_CVT_PLINE = '1604'; //---------------------------------------------------------------------------- // Query menu //---------------------------------------------------------------------------- M_ANALYZE_SELECT = '301'; M_QUERY_SELECT = '301'; M_ANALYZE_SQLQUERY = '302'; M_QUERY_SQLQUERY = '302'; M_ANALYZE_SELECTALL = '303'; M_QUERY_SELECTALL = '303'; M_ANALYZE_UNSELECT = '304'; M_QUERY_UNSELECT = '304'; M_ANALYZE_FIND = '305'; M_QUERY_FIND = '305'; M_ANALYZE_FIND_SELECTION = '306'; M_QUERY_FIND_SELECTION = '306'; M_ANALYZE_CALC_STATISTICS = '309'; M_QUERY_CALC_STATISTICS = '309'; //---------------------------------------------------------------------------- // Table, Maintenance, and Raster menus //---------------------------------------------------------------------------- M_TABLE_UPDATE_COLUMN = '405'; M_TABLE_APPEND = '411'; M_TABLE_GEOCODE = '407'; M_TABLE_CREATE_POINTS = '408'; M_TABLE_MERGE_USING_COLUMN = '406'; M_TABLE_IMPORT = '401'; M_TABLE_EXPORT = '402'; M_TABLE_MODIFY_STRUCTURE = '404'; M_TABLE_DELETE = '409'; M_TABLE_RENAME = '410'; M_TABLE_PACK = '403'; M_TABLE_MAKEMAPPABLE = '415'; M_TABLE_UNLINK = '416'; M_TABLE_REFRESH = '417'; M_TABLE_CHANGESYMBOL = '418'; M_TABLE_RASTER_STYLE = '414'; M_TABLE_RASTER_REG = '413'; M_TOOLS_RASTER_REG = '1730'; //---------------------------------------------------------------------------- // Options menu //---------------------------------------------------------------------------- M_FORMAT_PICK_LINE = '501'; M_FORMAT_PICK_FILL = '502'; M_FORMAT_PICK_SYMBOL = '503'; M_FORMAT_PICK_FONT = '504'; M_WINDOW_BUTTONPAD = '605'; M_WINDOW_LEGEND = '606'; M_WINDOW_STATISTICS = '607'; M_WINDOW_MAPBASIC = '608'; M_WINDOW_STATUSBAR = '616'; M_FORMAT_CUSTOM_COLORS = '617'; M_EDIT_PREFERENCES = '208'; M_EDIT_PREFERENCES_SYSTEM = '210'; M_EDIT_PREFERENCES_FILE = '211'; M_EDIT_PREFERENCES_MAP = '212'; M_EDIT_PREFERENCES_COUNTRY = '213'; M_EDIT_PREFERENCES_PATH = '214'; //---------------------------------------------------------------------------- // Window menu //---------------------------------------------------------------------------- M_WINDOW_BROWSE = '601'; M_WINDOW_MAP = '602'; M_WINDOW_GRAPH = '603'; M_WINDOW_LAYOUT = '604'; M_WINDOW_REDISTRICT = '615'; M_WINDOW_REDRAW = '610'; M_WINDOW_TILE = '611'; M_WINDOW_CASCADE = '612'; M_WINDOW_ARRANGEICONS = '613'; M_WINDOW_MORE = '614'; M_WINDOW_FIRST = '620'; // - - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - // Note: the 2nd through 80th windows can be accessed as (M_WINDOW_FIRST+i-1) // - - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - //---------------------------------------------------------------------------- // Help menu //---------------------------------------------------------------------------- M_HELP_CONTENTS = '1202'; M_HELP_SEARCH = '1203'; M_HELP_USE_HELP = '1204'; M_HELP_TECHSUPPORT = '1208'; M_HELP_CONNECT_MIFORUM = '1209'; M_HELP_ABOUT = '1205'; M_HELP_CONTEXTSENSITIVE = '1201'; M_HELP_HELPMODE = '1206'; //---------------------------------------------------------------------------- // Browse menu //---------------------------------------------------------------------------- M_BROWSE_PICK_FIELDS = '704'; M_BROWSE_OPTIONS = '703'; //---------------------------------------------------------------------------- // Map menu //---------------------------------------------------------------------------- M_MAP_LAYER_CONTROL = '801'; M_MAP_THEMATIC = '307'; M_MAP_MODIFY_THEMATIC = '308'; M_MAP_CHANGE_VIEW = '805'; M_MAP_CLONE_MAPPER = '811'; M_MAP_PREVIOUS = '806'; M_MAP_ENTIRE_LAYER = '807'; M_MAP_CLEAR_CUSTOM_LABELS = '814'; M_MAP_SAVE_COSMETIC = '809'; M_MAP_CLEAR_COSMETIC = '810'; M_MAP_SET_CLIP_REGION = '812'; M_MAP_CLIP_REGION_ONOFF = '813'; M_MAP_SETUPDIGITIZER = '803'; M_MAP_OPTIONS = '802'; //---------------------------------------------------------------------------- // Layout menu //---------------------------------------------------------------------------- M_LAYOUT_CHANGE_VIEW = '902'; M_LAYOUT_ACTUAL = '903'; M_LAYOUT_ENTIRE = '904'; M_LAYOUT_PREVIOUS = '905'; M_LAYOUT_BRING2FRONT = '906'; M_LAYOUT_SEND2BACK = '907'; M_LAYOUT_ALIGN = '908'; M_LAYOUT_DROPSHADOWS = '909'; M_LAYOUT_DISPLAYOPTIONS = '901'; //---------------------------------------------------------------------------- // Graph menu //---------------------------------------------------------------------------- M_GRAPH_TYPE = '1001'; M_GRAPH_LABEL_AXIS = '1002'; M_GRAPH_VALUE_AXIS = '1003'; M_GRAPH_SERIES = '1004'; //---------------------------------------------------------------------------- // MapBasic menu //---------------------------------------------------------------------------- M_MAPBASIC_CLEAR = '1101'; M_MAPBASIC_SAVECONTENTS = '1102'; //---------------------------------------------------------------------------- // Redistrict menu //---------------------------------------------------------------------------- M_REDISTRICT_ASSIGN = '705'; M_REDISTRICT_TARGET = '706'; M_REDISTRICT_ADD = '707'; M_REDISTRICT_DELETE = '708'; M_REDISTRICT_OPTIONS = '709'; //---------------------------------------------------------------------------- // Main Buttonpad //---------------------------------------------------------------------------- M_TOOLS_SELECTOR = '1701'; M_TOOLS_SEARCH_RECT = '1722'; M_TOOLS_SEARCH_RADIUS = '1703'; M_TOOLS_SEARCH_BOUNDARY = '1704'; M_TOOLS_EXPAND = '1705'; M_TOOLS_SHRINK = '1706'; M_TOOLS_RECENTER = '1702'; M_TOOLS_PNT_QUERY = '1707'; M_TOOLS_LABELER = '1708'; M_TOOLS_DRAGWINDOW = '1734'; M_TOOLS_RULER = '1710'; //---------------------------------------------------------------------------- // Drawing Buttonpad //---------------------------------------------------------------------------- M_TOOLS_POINT = '1711'; M_TOOLS_LINE = '1712'; M_TOOLS_POLYLINE = '1713'; M_TOOLS_ARC = '1716'; M_TOOLS_POLYGON = '1714'; M_TOOLS_ELLIPSE = '1715'; M_TOOLS_RECTANGLE = '1717'; M_TOOLS_ROUNDEDRECT = '1718'; M_TOOLS_TEXT = '1709'; M_TOOLS_FRAME = '1719'; M_TOOLS_ADD_NODE = '1723'; //---------------------------------------------------------------------------- // Menu and ButtonPad items that do not appear in the standard menus //---------------------------------------------------------------------------- M_TOOLS_MAPBASIC = '1720'; M_TOOLS_SEARCH_POLYGON = '1733'; //---------------------------------------------------------------------------- // Constants whose names have changed: these are left for backward // compatibility with existing programs. Recommended action is to use // the new name as indicated. Note that there might be some functiona // difference between the old functiona and the current functionality. //---------------------------------------------------------------------------- // M_ANALYZE_CUSTOMIZE_LEGEND M_MAP_MODIFY_THEMATIC // M_ANALYZE_SHADE M_MAP_THEMATIC // M_BROWSE_GRID M_BROWSE_OPTIONS // M_BROWSE_NEW_RECORD M_EDIT_NEW_ROW // M_FILE_ABOUT M_HELP_ABOUT // M_FILE_HELP M_HELP_CONTENTS // M_FILE_PRINT_SETUP M_FILE_PAGE_SETUP // M_LAYOUT_LAYOUT_SIZE M_LAYOUT_CHANGE_VIEW // M_MAP_SETUNITS M_MAP_OPTIONS // M_OBJECTS_BREAKPOLY M_OBJECTS_CVT_PLINE // M_OBJECTS_MERGE M_OBJECTS_COMBINE // M_OBJECTS_RESHAPE M_EDIT_RESHAPE // M_WINDOW_EXPORT_WINDOW M_FILE_SAVE_WINDOW_AS // M_WINDOW_TOOL_PALETTE M_WINDOW_BUTTONPAD //---------------------------------------------------------------------------- // Obsolete menu items that are not used in the current version of MapInfo //---------------------------------------------------------------------------- // M_BROWSE_EDIT 701 // 'OBSOLETE - DOES NOTHING // M_MAP_AUTOLABEL 804 // 'OBSOLETE - DOES NOTHING // M_MAP_PROJECTION 808 // 'SAME AS M_MAP_OPTIONS //============================================================================ // end of MENU.DEF //============================================================================ Implementation End.Hooks - аспекты реализации
| Раздел Подземелье Магов |
Моя обзорная (DLL) вызвала множество вопросов, большая часть которых касалась использования глобальных ловушек (Hook) и размещению разного рода ресурсов в DLL. О ресурсах поговорим в следующий раз, а пока попробуем разобраться с ловушками.
Скачать проект : (76 K)
Сразу хочу сделать несколько оговорок: речь в дальнейшем пойдёт только о 32-х разрядной Windows и о глобальных ловушках, т.к. именно при их программировании возникает большинство ошибок; все примеры будут даваться на Delphi, т.к. примеров и описаний для любителей С++ достаточно.
Давайте сначала разберёмся почему, иногда, даже опытные программисты допускают ошибки при написании глобальных ловушек. Первая, и самая распространённая причина: многие программисты, перейдя от 16-ти разрядной к 32-х разрядной Windows, порой забывают об изолированности адресных пространств процессов, такая забывчивость прощается при написании локальных ловушек, в случае с глобальными она может стать фатальной (подробнее об этом рассказано дальше в статье). Второй причиной является то, что в SDK (да и в MSDN тоже) даётся недостаточно информации по данной тематике, а та что есть часто трактуется неверно. Третья причина… хотя, думаю, стоит остановиться пока на этом.
Дальнейшее повествование предполагает, что читатель знаком с основными принципами работы с DLL и хотя бы в общих чертах представляет механизм их написания.
Что же происходит в системе когда мы "ставим" ловушку и что это вообще такое - ловушка ?
Ловушка (hook) - это механизм Windows, позволяющий перехватывать события, предназначенные некоторому приложению, до того как эти события до этого приложения дойдут.
Функции-фильтры - это функции, получающие уведомления о произошедшем событии от ловушки.
В зависимости от типа ловушки функции-фильтры могут изменять события, отменять их или просто реагировать на них. Таким образом, когда мы говорим "установил ловушку" мы подразумеваем процесс прикрепления функции-фильтра к выбранному нами типу ловушки. Итак, когда мы в своей программе используем функцию SetWindowsHookEx мы прикрепляем функцию-фильтр, указатель на которую мы и передаём вторым параметром, пример SetWindowsHookEx(WH_SHELL, @ShellHook, HInstance, 0); в данном случае ShellHook - это и есть функция-фильтр. В дальнейшем, под словосочетанием "установили ловушку" будем понимать присоединение функции-фильтра к ловушке.
Что же происходит после того, как мы установили глобальную ловушку ? Понимание следующего параграфа является ключом для понимания механизма работы ловушек Windows, располагающихся в DLL. Если вы не поймёте его, вернитесь и перечитайте заново и так до тех пор, пока всё не станет ясным.
Наш Process1 устанавливает глобальную ловушку из DLL находящейся в адресном пространстве (АП) нашего процесса (Process1). DLL, находящаяся в АП процесса1 имеет свои данные, обозначенные на рисунке как Dll data. Когда система посылает событие, на которое мы установили ловушку, в Process2, то в Process2 отображается код DLL, находящийся в первом процессе (Dll code), НО НЕ ДАННЫЕ ! Все данные, только что отображённой в Process2 DLL, инициализируются заново (т.е. равны 0, nil, False в зависимости от типа). То есть, Process2 знать не знает о существовании Process1, и всё что в нём находится никак не относится к АП первого процесса, из которого произошло отображение кода DLL. В библиотеки, находящиеся не в АП вашего процесса, можно посылать только процессо-независимые данные, такие как, к примеру, дескрипторы окон (под термином "посылка" в данном случае подразумевается использование функций PostMessage() и SendMessage()).
(О смысле красных овалов на рисунке поговорим позже, сейчас не стоит обращать на них внимания).
Если выше прочитанное вам понятно, то продолжим наш разговор и рассмотрим, что происходит, когда мы устанавливаем вторую ловушку такого же типа, что и первая. При установке в системе двух одинаковых ловушек Windows выстраивает их в цепочку. Когда система посылает сообщение, на которое мы установили ловушки, то первой срабатывает последняя ловушка в цепочке, т.е. hook n (см. рисунок) . О том, что бы сообщение дошло до n-1 ловушки (hook n-1) должен позаботится сам программист. Вот на этом-то этапе очень часто возникают ошибки.
Для вызова следующей ловушки в цепочке ловушек в Windows используется функция CallNextHookEx, первым параметром которой является дескриптор текущей ловушки, получаемый функцией SetWindowsHookEx. Теперь внимание: мы установили ловушку в Process1, т.е. функция SetWindowsHookEx выполнялась в DLL, находящейся в АП Process1 (см. Рисунок 1) и, соответственно, дескриптор установленной ловушки возвращаемый функцией SetWindowsHookEx принадлежит данным DLL, находящимся в АП Process1. Пусть в Process2 возникает событие на которое поставлена ловушка, тогда Dll из первого процесса проецируется на АП Process2, а данные DLL в Process2 инициализируются заново, и получается, что в Process2 в переменной, в которой "лежал" дескриптор поставленной ловушки в Process1, будет равен 0. Функция-фильтр Process2, отработав, должна будет передать сообщение дальше по цепочке ловушек, т.е. выполнить функцию CallNextHookEx, первым параметром которой должен быть дескриптор текущей ловушки, но в данных DLL, находящейся в Process2 нет этого дескриптора (переменная, которая должна содержать его содержит ноль). "Как же быть в таком случае ? Как же нам узнать дескриптор ловушки, поставленной в другом процессе, если сами процессы ничего не знают друг о друге ?" - спросите вы. На этот вопрос я отвечу чуть позже, а пока давайте поверхностно пробежимся по типам ловушек, хотя информация о типах полностью приведена в SDK.
Как мы уже знаем, ловушка устанавливается с помощью Win32 API функции SetWindowsHookEx(): function SetWindowsHookEx(idHook: integer; lpfn: TFNHookProc; hmod: HINST; dwThreadID: DWORD): HHOOK; stdcall; idHook: описывает тип устанавливаемой ловушки. Данный параметр может принимать одно из следующих значений:
| Константа | Описание |
| WH_CALLWNDPROC | Фильтр процедуры окна. Функция-фильтр ловушки вызывается, когда процедуре окна посылается сообщение. Windows вызывает этот хук при каждом вызове функции SendMessage. |
| WH_CALLWNDPROCRET | Функция-фильтр, контролирующая сообщения после их обработки процедурой окна приемника. |
| WH_CBT | В литературе встречаются следующие названия для этого типа фильтров: "тренировочный" или "обучающий". Данная ловушка вызывается перед обработкой большинства сообщений окон, мыши и клавиатуры |
| WH_DEBUG | Функция-фильтр, предназначенная для отладки. Функция-фильтр ловушки вызывается перед любой другой ловушкой Windows. Удобный инструмент для отладки и контроля ловушек. |
| WH_GETMESSAGE | Функция-фильтр обработки сообщений. Функция-фильтр ловушки вызывается всегда, когда из очереди приложения считывается любое сообщение. |
| WH_HARDWARE | Функция-фильтр, обрабатывающая сообщения оборудования. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение оборудования. |
| WH_JOURNALPLAYBACK | Функция-фильтр вызывается, когда из очереди системы считывается любое сообщение. Используется для вставки в очередь системных событий. |
| WH_JOURNALRECORD | Функция-фильтр вызывается, когда из очереди системы запрашивается какое-либо событие. Используется для регистрации системных событий. |
| WH_KEYBOARD | Функция-фильтр "обработки" клавиатуры. Наверное, наиболее часто используемый тип ловушки. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщения wm_KeyDown или wm_KeyUp. |
| WH_KEYBOARD_LL | Низкоуровневый фильтр клавиатуры. |
| WH_MOUSE | Функция-фильтр, обрабатывающая сообщения мыши. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение мыши. |
| WH_MOUSE_LL | Низкоуровневый фильтр мыши. |
| WH_MSGFILTER | Функция-фильтр специального сообщения. Функция-фильтр ловушки вызывается, когда сообщение должно быть обработано диалоговым окном приложения, меню или окном приложения. |
| WH_SHELL | Фильтр приложения оболочки. Функция-фильтр ловушки вызывается, когда создаются и разрушаются окна верхнего уровня или когда приложению-оболочке требуется стать активным. |
Что бы упредить шквал писем в мой адрес, скажу сразу, что каждый, из вышеперечисленных, типов имеет свои особенности, о которых каждый может прочитать в SDK, MSDN или же найти их описание в Internet-e.
lpfn : это адрес функции-фильтра, которая является функцией обратного вызова. Функция-фильтр имеет тип TFNHookProc, определение которого выглядит следующим образом: TFNHookProc = function (code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall; Значение каждого из параметров функции-фильтра ловушки изменяется в зависимости от типа устанавливаемой ловушки. За более подробными разъяснениями значений параметров обращайтесь к справке по Win32 API.
hmod: данный параметр должен иметь значение hInstance в EXE или DLL-файлах, в которых содержится функция-фильтр ловушки (напомню, что это функция обратного вызова). Если речь идёт о глобальных ловушках, то данный параметр может принимать только дескриптор DLL, из которой устанавливается ловушка. Причина очевидна - EXE-файл не может быть отображён на АП другого процесса, тогда как DLL-фалы специально созданы для этого. Подчеркну это обстоятельство ещё раз: глобальные ловушки могут располагаться только в DLL, но никак не в EXE файлах !
dwThreadID: данный параметр идентифицирует поток, с которым будет связана ловушка. Мы ведём речь о глобальных ловушках, поэтому данный параметр будет всегда равен 0, что означает, что ловушка будет связана со всеми потоками в системе.
Возвращаемое значение: функция SetWindowsHookEx возвращает дескриптор установленной ловушки, именно этот дескриптор нам и надо будет сделать доступным ВСЕМ экземплярам отображаемой DLL. Как это сделать я расскажу после небольшого примера, показывающего на практике необходимость сохранять дескриптор ловушки для того, что бы суметь вызвать предыдущую ловушку в цепочке.
Замечание::
при установке двух ловушек разного типа, система создаст две цепочки ловушек. Т.е. каждому типу ловушки соответствует своя цепочка. Так при установке ловушки типа WH_MOUSE и WH_KEYBOARD обе эти ловушки будут находиться в разных цепочках и, соответственно, будут обрабатываться независимо друг от друга.
Для удаления функции-фильтра из очереди необходимо вызвать функцию UnhookWindowsHookEx. Данная функция принимает дескриптор ловушки, полученный функцией SetWindowsHookEx. Если удаление не удалось, то функция возвращает ноль, иначе не нулевое значение. В дальнейшем, под выражением "снять ловушку" будем подразумевать удаление функции-фильтра.
Теперь, когда вам известно как устанавливать ловушку и как её снимать, рассмотрим пару примеров, которые дадут наглядное представление об изолированности АП процессов и укажут на одну из самых распространённых ошибок.
Откройте каталог Example1, из прилагаемого к статье файла, далее зайдите в каталоги First и Second и скомпилируйте все имеющиеся в этих каталогах проекты. В итоге вы должны получить в одном каталоге файлы MainProg1.exe и hook_dll1.dll, и во втором - MainProg2.exe и hook_dll2.dll (не забудьте, что *.DLL файлы могут быть не видны, из-за того, что у вас в свойствах обозревателя выбран пункт "Не показывать скрытые и системные файлы" ) . Запустите MainProg1.exe и MainProg2.exe, расположите появившиеся окошки рядом. Теперь в окне MainProg1 нажмите "Load DLL and set hook", как только вы нажмёте на эту кнопку, ловушка типа WH_GETMESSAGE установится и теперь, когда какой либо процесс будет считывать сообщение из очереди, в этот процесс будет отображена hook_dll1.dll и выполнена функция-фильтр. При отображении в процесс этой DLL будет выводиться сообщение с именем модуля, из которого был загружен процесс, отобразивший эту DLL в своё АП. Если ловушка установлена успешно, - будет выведено соответствующее сообщение. Проделайте те же действия со второй формой (Example1/Process2). Теперь, после успешной установки двух ловушек, попробуйте кликнуть правой кнопкой мыши на какой-либо форме (но не на форме MainProg2). Вы увидите сообщение "HOOK2 working !", что означает что сработала вторая ловушка, которую мы установили последней и которая находится в конце очереди, но, несмотря на то, что в коде функции-фильтра второй ловушки мы пытались передать сообщение следующей ловушке (установленной нами из MainProg1 CallNextHookEx(SysHook, Code, wParam, lParam); первая ловушка не выполняется, потому что в процессе, которому принадлежит форма, на которой вы произвели клик, переменная SysHook будет равна нулю. Надеюсь, это понятно, если нет, - начинайте читать заново ;) Теперь попробуйте так же кликнуть правой кнопкой мыши на форму Example1/Process2 и вы увидите сначала сообщение "HOOK2 working !", а затем "HOOK1 working !". Почему ? - спросите вы. А потому, что в АП Process2 (в данных DLL) лежит дескриптор установленной из этого процесса ловушки и функция CallNextHookEx(SysHook, Code, wParam, lParam); работает как надо (SysHook не равна нулю, мы её сохранили в глобальных данных DLL - см. исходный код). Далее, попробуйте снять вторую ловушку (удалить функцию-фильтр из очереди) нажав на кнопку "TurnOff the hook". После того, как ловушка будет снята, попробуйте снова где-либо нажать правую кнопку мыши. При этом вы увидите, что ловушка, поставленная из первого приложения работает (будет появляться сообщение "HOOK1 working !"). Естественно, если вы, не сняв ловушку, закроете приложение, из которого она была установлена, ловушка будет уничтожена, а DLL выгружена, если более ни одним приложением не используется. ( Хотя, строго говоря, это не совсем так. Дело в том, что Windows использует механизм кэширования DLL в оперативной памяти. Делается это для того, что бы уменьшить накладные расходы на загрузку DLL с жёсткого диска в случае, если к этой DLL часто обращаются различные приложения, т.е. отображают эту DLL на своё АП. Более подробно об этом механизме можно почитать в специализированной литературе, для нас же, как для программистов, данное свойство ОС остаётся, как правило, прозрачным).
Думаю, теперь, разобравшись в исходных кодах библиотек из первого примера, вы поняли, как НЕ надо писать DLL, из которых вы устанавливаете глобальные ловушки. Представьте, что пользователь, использующий вашу программу, в которой задействованы глобальные ловушки, запустит другую программу, которая так же установит тот же вид ловушки, что и ваша, но установит её в конец очереди, в таком случае, если та, вторая программа, будет написана неправильно - ваша программа перестанет работать потому что вашей ловушке не будет передаваться сообщение из впереди стоящей. Это пример того, как некачественная работа одного программиста может испортить прекрасно выполненную работу другого.
Замечание:
если вы работаете на Windows 2000, то вышеописанный пример будет работать иначе. Дело в том, что в Windows 2000 изменён механизм вызова ловушки, стоящей в очереди. Программисты Microsoft довели-таки его до ума, и в новой ОС он стал, по моему личному мнению, более логичен. В Windows 2000 если у вас имеется цепочка ловушек, то при выполнении функции CallNextHookEx(0, nCode, wParam, lParam ) вызывается следующая ловушка в цепочке, т.е. отпадает необходимость в передачи дескриптора, возвращаемого функцией SetWindowsHookEx. Таким образом, в первом примере будут вызываться обе ловушки и при клике на правую кнопку мыши вы увидите сообщение "HOOK2 working !", а затем и "HOOK1 working !". Рассмотрев и опробовав пример 2, вы увидите, что в Windows 2000 оба примера работают одинаково, хотя второй пример гораздо более сложен в плане реализации. Так как мы стремимся к тому, что бы наши программы были устойчивы в работе под любой версией Windows (имеются ввиду 32-х разрядные и выше), то в связи с этим я бы рекомендовал в ваших программах использовать метод, описанный далее в статье, а ещё лучше - делать проверку на ОС, под которой была запущена ваша программа и соответствующим образом работать с ловушками. К сожалению у меня нет описания, содержащего декларацию "новой" функции CallNextHookEx(), нововведение было обнаружено мной в результате тестирования своих программ на Windows 2000, поэтому возможны какие-то нюансы при работе с этой функцией. Лично я, работая с ловушками в среде Windows 2000, на другие изменения не натыкался, если кто-то располагает какой-либо интересной информацией по данному вопросу - буду признателен, если со мной ею поделятся.
Теперь поговорим о том, как избежать неприятных ситуаций, используя глобальные ловушки.
Для того, что бы все экземпляры DLL, находящиеся в разных процессах, имели доступ к дескриптору ловушки, надо выделить какую-то область, доступ к которой будут иметь все "желающие". Для этого воспользуемся одним из мощнейших механизмов Windows под названием "Файлы, отображённые в память" (Memory Mapped Files). В цели данной статьи не входит углубление в подробности работы с данным механизмом, так что если он кого-то заинтересует всерьёз - рекомендую почитать о нём в литературе, общие же понятия я постараюсь вкратце осветить. Механизм файлов, отображённых в память (MMF - Memory Mapped Files) позволяет резервировать определённую область АП системы Windows, для которой назначаются страницы физической памяти. Таким образом, с помощью MMF можно отображать в память не только файлы, но и данные, ссылаясь на них из своих программ с помощью указателей. В первом приближении работу механизма MMF можно представить следующим образом: Process1 создаёт отображение, которое связывает с некими данными (будь то файл на диске или значение неких переменных в самом Process1) и может изменять отображённые данные; затем Process2 так же отображает некие свои данные в тоже отображение, что и Process1, таким образом, изменения, внесённые Process1 в отображённые данные, будут видны Process2 и наоборот (см. Рисунок 1 - красный овал c именем Global Data и есть зарезервированное под совместные нужды двух процессов АП). Данное приближение, вообще говоря, грубое, потому что всё намного сложнее, но для наших "нужд" этого будет вполне достаточно. Мы не будем создавать никаких временных файлов для передачи информации между процессами, мы воспользуемся файлом подкачки Windows (файл страничного обмена), таким образом, нам не придётся ни создавать ни уничтожать файлы, а придётся просто создать некоторое АП, которое будет доступно нашим приложениям и которое будет автоматически освобождаться системой, когда в нём отпадёт необходимость. К тому же, ясно, что работа с файлом подкачки куда быстрее, чем с обычным файлом, хранящимся на диске. Таким образом, к рассмотренному вами ранее Example1 можно применить следующий сценарий: при загрузки вашей программой (MainProg1.exe) библиотеки hook_dll1.dll эта библиотека создаёт отображённый в память файл, в котором сохраняет значение дескриптора установленной ловушки; затем некий процесс, в котором произошло событие, на которое была установлена ловушка, отображает на своё АП код hook_dll1.dll и уже новый экземпляр hook_dll1.dll, находящийся в АП другого процесса использует то же отображение, что и библиотека, из который была установлена ловушка, т.е. будет иметь доступ к сохранённому значению дескриптора установленной ловушки. Таким образом, вызов функции CallNextHookEx(Hook_Handle, Code, wParam, lParam); будет происходить вполне корректно, т.к. значение Hook_Handle будет содержать не 0, как в примере1, а значение, возвращённое функцией SetWindowsHookEx из первого экземпляра DLL. Возможно, данные объяснения кажутся вам запутанными, но после просмотра примера и повторного прочтения этих объяснений всё встанет на свои места.
Теперь пару слов о программной реализации всего вышесказанного.
| CreateFileMapping() | Создаёт объект файлового отображения. Данная функция возвращает указатель (handle) на объект файлового отображения. |
| MapViewOfFile() | Данная функция отображает образ объекта файлового отображения на АП процесса, из которого она была вызвана. Первым параметром данной функции является результат выполнения функции CreateFileMapping(). Результатом работы данной функции является указатель на начало выделенного АП (уже в том процессе, из которого была вызвана данная функция). См. Рисунок 1. - красные овалы в Process1 и Process2 под названием GD1 и GD2 (Global Data 1/2). Следует отметить, что для различных процессов, использующих экземпляры одной и той же DLL, адреса выделенных областей будут различными (хотя могут и совпадать, но это совпадение носит вероятностный характер), хотя данные, на которые они будут ссылаться, одни и те же ! |
| UnmapViewOfFile() | Данная функция закрывает отображённый в память файл и освобождает его дескриптор. При удачном закрытие функция возвращает ненулевое значение и 0 в случае неудачи. |
Замечание:
первым параметром функции CreateFileMapping() должен быть передан дескриптор файла, которого мы собираемся отобразить. Т.к. мы собираемся отображать данные в файл подкачки, то следует передавать значение $FFFFFFFF или DWORD(-1), что соответствует тому же значению; но т.к. грядёт эра 64-разрядных систем, стоит использовать значение INVALID_HANDLE_VALUE, которое будет в 64 разрядной системе равно $FFFFFFFFFFFFFFFF соответственно. Для тех, кто переходил с ранних версий Delphi на более поздние (к примеру с Delphi2 на Delphi4) те, возможно, сталкивались с такого рода проблемами в своих программах. Так как мы будем создавать именованный объект файлового отображения, то последним параметром функции CreateFileMapping() передадим имя объекта, которое впоследствии будут использовать другие процессы для ссылки на ту же область памяти. Следует упомянуть о том, что создаваемый таким образом объект должен иметь фиксированный размер, т.е. не может его изменять по ходу программы.
Теперь мы владеем всеми необходимыми знаниями для рассмотрения второго примера. Откройте каталог Example2 и выполните те же действия, что и в первом примере, предварительно внимательно разобравшись в исходных кодах. После того как вы запустите оба приложения и установите из них две функции-фильтра одного типа, попробуйте кликнуть правой кнопкой мыши на любом из окон и вы увидите, что теперь отрабатывают обе установленные ловушки, независимо от того, на каком из окон произошло нажатие кнопки мыши (т.е. несмотря на то, из какого экземпляра DLL выполняется вызов функции CallNextHookEx() ). Таким образом, когда какое-либо приложение будет отображать на своё АП DLL, в которой находится функция-фильтр, этот экземпляр DLL будет иметь доступ к данным, отображённым в память из Process1 или Process2, в зависимости от DLL. Думаю, после столь подробных объяснений всё должно быть понятно.
В завершении напишем программу, которая будет устанавливать ловушку типа WH_KEYBOARD и записывать в файл значения нажатых клавиш во всех приложениях (программа будет накапливать в буфере значения нажатых клавиш и как только их количество превысит 40 - все значения будут выведены в соответствующее окно формы). Попутно, в данном примере, новички могут найти ответы на многие вопросы, часто задаваемые в различных форумах. Все объяснения будут даваться в виде комментариев к исходному коду. Откройте каталог Example3, в нём вы найдёте исходные коды библиотеки и главной программы, - разберитесь с ними, а затем откомпилируйте и сами попробуйте программу в действии.
Благодарю а за оказанную поддержку.
Список использованной литературы:
Алексей Павлов
Moscow Power Engineering Institute (Technical University)
Faculty of Nuclear Power Plants
для публикации на статья предоставлена
Инспектор объектов и метаданные
| й Гурин, дата публикации 28 апреля 2003г. |
Предмет данной статьи - инспектор объектов как средство, доступное конечному пользователю некоторой прикладной программы. Само понятие "инспектор" трактуется в данном случае очень широко: инспектор - это инструмент прикладной программы, с помощью которого пользователь может посмотреть и изменить свойства тех объектов, с которыми он работает. Отметим, что речь идет о любых объектах прикладного уровня, а не только о визуальных компонентах (как в Delphi).
Использование функциональности IE или заметки о WebBrowser
| Раздел Подземелье Магов | Игорь Осов'як , дата публикации 28 февраля 2001г. |
Содержание:
| Введение. |
Довольно часто современному программисту приходится решать вопросы, которые связанные с отображением или обработкой информации, представленной в виде html-ресурсов. Например, на некотором сайте приводятся ежедневные котировки акций и Вам нужно собирать и обрабатывать статистку за определенный период времени. Или нужно создать сторожа, который "наблюдает" за он-лайн прайс-листом конкурента и который должен "предупреждать" об изменениях цены на определенные позиции. Или нужно написать "паука", который должен пробегать по некоторому сайту в поисках определенного текста, причем в процессе пробежки ему нужно заполнить несколько регистрационных форм, а фрагменты текста, которые он отыскал - выделить определенным цветом. Можно назвать бесконечно много подобных примеров, но суть их сводится к одному - получение веб-страницы, извлечение из нее определенной части HTML-кода программными средствами (парсинг), и, возможно, программное влияние на эту часть кода.
Можно, конечно, используя WinInet.dll, получить доступ к требуемому веб-ресурсу, а затем с помощью многочисленных строковых функций получить интересующею нас ее часть. Эта технология вполне работает, но довольно трудоемкая и, в большинстве случаев далека от элегантности. Другой путь - использование функциональности Microsoft Internet Explorer.
Internet Explorer (далее - IE)- это не одна отдельная программа, а целая коллекция компонент, которые можно использовать при разработке своих приложений. Наиболее интересными с точки зрения прикладного программиста есть компоненты из shdocvw.dll и mshtml.dll. Первая DLL содержит WebBrowser - Microsoft ActiveX control, используемый для визуального просмотра веб-страниц (рабочая область окна Internet Explorer и есть тот самый компонент WebBrowser). Вторая DLL содержит синтаксический анализатор HTML кода, а также средства взаимодействия с отдельными элементами этого кода. По скромному мнению и.
Целью написания этого цикла статей есть демонстрация некоторых приемов использования функциональности ActiveX-контрола WebBrowser в прикладных дельфийских программах. численных веб-ресурсах. То небольшое, что отличает этот материал (по мнению чных - это во-первых, ориентация на Delphi, а во вторых - обобщение личного опыта рода благодарность тем людям, которые довольно сильно помогли мне в то время, когда я делал первые шаги в направлении, к которому имеет отношение эта статья. Я особенно благодарен Борису Ладугину за тот "ликбез" в части COM, который он провел со мной в личной переписке, а также Лене Филиповой и всем местным жителям, советы которых на "круглом столе" не раз давали толчок для движения в верном направлении.
аммирования на Delphi и хотя бы в общих чертах знаком с COM-технологиями. Хотя материала, но, надеюсь, дадут хотя бы направление поиска в случае затруднений.
| Где в Delphi живет WebBrowser? |
Для любого зарегистрированного в палитре ActivX-контрола Delphi при импорте создает класс-оболочку, которая наследуется от TOleControl . Для начала не станем углубляться в особенности TOleControl и производных от нее оболочек - ибо сие дело поначалу может не так прояснить, как запутать ситуацию. Отметим только, что оболочка и сам ActiveX есть несколько разные вещи. Собственно TOleControl и производные от него оболочки есть не более, чем средство, которое обеспечивают возможность работы с ActiveX, как с "родными" VCL-компонентами. Для WebBrowser от IE такой оболочкой есть TWebBrowser. Если Вы используете Delphi5, то соответствующий компонент можно отыскать на закладке "Internet " палитры компонентов. Если Вы работаете с Delphi4 , то Вам нужно провести импорт соответствующего ActiveX-контрола. Для этого следует воспользоваться меню "Import ActiveX Control" и в списке ActiveX выбрать "Microsoft Internet Controls" (разумеется, у Вас должен быть установлен IE). Компонент-оболочка по умолчанию устанавливается на закладку "ActiveX" палитры компонентов. Если Вам нужен не только компонент для отображения Web-страниц, а Вы еще собираетесь проводить парсинг загруженных страниц, то Вам также следует провести импорт mshtml.dll. Это можно сделать при помощи меню Import Type Library, выбрав в списке строчку Microsoft HTML Object Library.
Даже если Вы используете Delphi5, в определенных случаях есть смысл исключить предустановленный компонент TWebBrowser и провести импорт соответствующих компонентов самостоятельно. Это может быть необходимым в случае, если Вы желаете написать приложение, совместимое с IE4, а в Delphi5 модули mshtml.pas и shdocvw.pas рассчитаны на использование IE5. И как следствие, довольно много интерфейсов, которые декларируются в соответствующих модулях, не будут поддерживаться IE4 (к примеру, тот же IHTMLDocument3). Или наоборот, Вас, возможно, заинтересовала какая-то особенность новой версии IE, декларация которой отсутствует в mshtml.pas (или shdocvw.pas) c поставки Delphi.
Если Вы решитесь для Delphi5 проводить самостоятельный импорт mshtml.dll через Import Type Library - уберите галочку с "Generate Component Wrapper" - в противном случае Delphi создаст никому не нужные класы-оболочки для интерфейсов и раздует результирующий файл (mshtml_tbl.pas)до несусветных размеров.
Понятно, что если Вы провели импорт, то в Delphi5 Вам вместо uses mshtml,shdocvw;
придется использовать uses mshtml_tbl,shdocvw_tbl;
Если Вы проведете импорт, то Вы наверняка обратите внимание на то, что помимо упоминаемого TWebBrowser рядышком будет TWebBrowser_V1. Что это за зверь? Ответ довольно прост - это совместимый с IE3 контрол. В IE4 он введен для совместимости с теми прикладными программами, которые разрабатывались в расчете на IE3.
И заканчивая тему экспорта - в библиотеке типов от IE довольно часто используются имена, которые есть зарезервироваными для Delphi. В большинстве случаев Delphi справляется с этой задачей (к примеру переименовывая метод type некоего интерфейса в type_). Но для mshtml.dll от IE5 есть один неприятный момент - там декларируется константа const True = $00000001; И если Вы делаете импорт в Delphi4 - то никакого переименования не происходит. B как следствие в каком-то безобидном месте наподобие нижеследующего implemantation uses mshtml_tbl; function IsOk:boolean; begin result:=true; // ..... end; получаете сообщение компилятора о несовместимости типов. Что делать?
Или смирится и писать: result:=system.true;< BR> или "научить" Delphi4 обходному маневру: перед импортом mshtml.dll добавить в DELPHI\BIN\tlibimp.sym две строчки: True False
| Содержание |
Где искать информацию?
Итак, мы уже разобрались, где наш контрол живет. И как его импортировать в случае необходимости.
Теперь несколько слов об дополнительных источниках информации. Если Вы работаете с Delphi5, то для начала можно посмотреть встроенную контекстную справку по TWebBrowser. Но к сожаленью, она довольно скудна, и описывает (и то поверхностно) только основные свойства компонента TWebBrowser. Вы ни слова не найдете об возможностях mshtml.dll (а там запрятаны основные вкусности). Наиболее радикальное решение - приобрести свежее издание MSDN (или работать с ее онлайновой версией ). Но и при таком решении не все будет гладко - так как MSDN в первую очередь не учебник, а справочник. И к тому же некоторые аспекты в нем освещены не так полно, как хотелось бы. Но увы, это пожалуй наиболее полный источник информации, пробелы в котором можно компенсировать только многочисленными экспериментами и анализом происходящего. Ответ на конкретный вопрос можно попытаться отыскать в конференциях. Можно и в "общих", таких как старый, добрый fido7.delphi.ru, или здесь, на . А также в "специализированных" - и (последняя - англоязычная). Также рекомендую сайт .
Я также надеюсь, что время, затраченное мной на написание, а Вами на прочтение этой статьи, потрачено не зря.
Ну, а если Вы находитесь в самом начале пути - то можно просмотреть статью Александра Лозовюка (рубрика Hello, world) ...
Несколько слов о реализации простого веб-броузера и не только ..
В принципе, создать простенький веб-броузер c использованием TWebBrowser - дело мало чем более одной минуты. Открываем новый проект, центрируем форму, в нижней части размещаем панель, на которую бросаем ComboBox для вввода URL, слева от нее соответствующий Label, справа кнопочку "Go". Разместим также главное действующие лицо TWebBrowser над панелью. Дадим более-менее вразумительные имена нашим компонентам (например, ComboBox можно назвать "selUrl"), проставим соответствующие опции выравнивания. Ну, и самая "трудная" часть задачи - создадим обработчик нажатия на кнопочку "Go": procedure TFormSimpleWB.btGoClick(Sender: TObject); var _URL, Flags, TargetFrameName, PostData, Headers: Olevariant; begin _URL := selUrl.Text; Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0; WebBrowser1.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers); end; Исходники этого "шедевра" (Delphi5) c теми дополнениями, о которых речь идет ниже, можно взять (3k)
Ну а теперь несколько более подробно. Для начала посмотрим список методов и свойств TWebBrowser. Здесь следует отличать "обычные" методы и свойства компонентов VCL, и те, которые "отражают" методы соответствующего ActiveX элемента. Первые нас не очень интересуют (если читатель имеет хотя бы небольшой опыт работы с Delphi, то по отношению к чисто VCL-свойствам типа Align , TabOrder ему должно быть все понятно.) Остановимся на второй группе свойств и методов.Их можно разделить на две группы - те, которые "отражают" default-интерфейс (в нашем случае это IWebBrowser2 и те, которые "отражают" нотификационный интерфейс DWebBrowserEvents2 ).
"Cвязку" между методами интерфейсов и методами класса-оболочки делает експерт импорта ActiveX, основываясь на особенностях реализации TOleControl. Проанализируйте исходники TOleControl и TWebBrowser - и Вы увидите эти связки. Это довольно интересное и довольно утомительное занятие ... Лично мне до конца пройти этот путь не хватило терпения - я остановился на той стадии, когда начал более-менее понимать основные принципы интеграции ActiveX в VCL. Для заинтересовавшихся подсказка - обратите в первую очередь внимание на методы TWebBrowser.InitControlData и на TOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod);
Да, вполне возможно, что читатель не знаком с основами СOM, и понятия "интерфейс", "нотификационный интерфейс" ему ни о чем не говорят. Я не знаю, смогу ли я в двух-трех предложениях компенсировать этот пробел. Но все - же попытаюсь. Если читатель ориентируется в COM-технологиях, но следующих несколько абзацев можно пропустить.
Итак, маленькое лирическое отступление в сторону COM
COM - это есть во первых, некий набор не нарушаемых ни при каких условиях правил, согласно которым одни программные объекты могут воспользоваться ресурсами других программных обьектов, а также средства операционной системы, которые обеспечивают это взаимодействие. Причем те объекты, которые используют ресурсы (далее клиенты), никогда не получают полного контроля над объектами, которые эти ресурсы отдают (далее - компоненты, или объекты COM)... Мало того, клиенту даже не обязательно иметь представление об общем устройстве объекта COM. Для их взаимодействия важно наличие оговоренного интерфейса взаимодействия и гарантии того, что этот интерфейс никогда не будет изменен.
Здесь под интерфейсом понимается набор определенных методов, которые должны быть реализованы объектом COM, и которые "предоставляются" клиенту. На уровне бинарного кода за интерфейсом стоит некая структура в памяти, которую реализует объект COM и которая предоставляет собой некую таблицу адресов методов обьекта COM. Когда говорят, что клиент получил интерфейс, то понимают, что ему стал известен адрес той структуры. Кроме того, клиент "знает", в каком порядке идут точки вхождения в этой таблице для соответствующих методов, так как клиент знаком с соответствующей спецификацией.
Внимательный читатель задаст вопрос - а как же с разделением адресного пространства, ведь довольно часто клиент и объект COM живут в разных процессах, и следовательно их адресные пространства изолированы друг от друга? Как же тогда клиент и объект COM работают с одной таблицей?
Эту проблему решает библиотека поддержки СOM, которая внедряет в адресное пространство клиента и сервера специальные служебные объекты, называемые заместителями (для клиента) и заглушками (для сервера) (здесь под сервером понимается тот процесс, который создал один или несколько экземпляров объектов COM). Таким образом клиент будет взаимодействовать с заглушкой, а сервер с заместителем. Организация взаимодействия между заглушкой и заместителем - проблема библиотеки поддержки COM.
К счастью, вся эта алхимия в большинстве случаев не требует от программиста какого-то либо вмешательства. Я во всяком случае, встречал довольно много программистов, которые активно используют COM-технологии, но понятия не имеют о тех вещах, которых мы вскользь коснулись выше.
Подытоживая, можно сказать, что интерфейс есть спецификация, которая на на уровне бинарного кода "отражается" в таблицу вызовов в памяти.
В СОМ интерфейсы - это все. Для клиента сервер представляет собой набор интерфейсов. Клиент с сервером может взаимодействовать только посредством интерфейсов. Мало того, клиент даже может не знать о всех интерфейсах, поддерживаемых сервером.
Все интерфейсы наследуются от базового интерфейса IUnnknown . Причем, если говорят о наследовании интерфейсов, то понимают не наследование реализации (с ней мы имеем дело, когда работаем в пределах объектной модели хотя бы того же Delphi), а наследование деклараций. Под наследованием деклараций понимается то, что если некий интерфейс IB наследуется от интерфейса IA, то в соответствующей таблице вызовов для интерфейса IB сначала будут идти адреса методов, которые декларируются в IA, а затем адреса методов от IB. Причем списки формальных параметров наследуемых методов не должны быть изменены. Если вспомнить, что интерфейсы есть спецификации, то становится понятным, почему по отношению к ним может идти речь только о наследовании деклараций. Конечно, при реализации конкретного COM-обьекта можно использовать технологию наследования реализации, но это будет внутреннее дело объекта, которое никак не затрагивает клиента.
В завершение разговора об COM, я хотел бы упомянуть о некоторых методах базового интерфейса IUnnknown, так как во первых, эти методы присутствуют в любом интерфейсе (вспомним о наследовании деклараций и о том, что любой интерфейс наследуется от IUnnknown) и во вторых, на использовании этих методов строится вся идеология работы с COM.
Итак, разрешите представить - QueryInterface. С помощью этого интерфейса клиент может определить, поддерживает ли COM-обьектом какой либо другой интерфейс, который известен клиенту, и получить указатель на тот интерфейс, если он поддерживается объектом. При работе с СOM, это пожалуй самый популярный вызов. В Dеlphi он иногда вызывается явно, иногда неявно. Неявный вызов происходит при применении оператора as для интерфейсных ссылок.
Интерфейс IUnnknown также декларирует два метода интерфейса AddRef и Release, которые ответственны за подсчет использования COM-обьекта (одно из требований к COM-обьектам - они должны уметь сами себя уничтожить, если в их услугах более никто не нуждается). Вам вряд ли придется вызывать эти методы напрямую, так как Delphi генерирует их вызовы автоматически.
Сейчас, пожалуй, самое время время взглянуть на mshtml.pas - как видим он почти на 100% состоит из одних деклараций интерфейсов - ведь нам как клиенту важно знать спецификацию. И совсем не обязательно быть в курсе особенностей реализации.
И напоследок два слова о нотификационных интерфейсах. Довольно часто бывает так, что COM-обьект должен сообщать клиенту о некоторых событиях. В таком случае клиент должен реализовать так называемый нотификационный интерфейс, который известен серверу и сообщить серверу о том, что им поддерживается этот интерфейс. Тогда сервер сможет извещать клиента об определенных событиях, делая вызовы методов нотификационного интерфейса. То есть в этом случае COM-сервер и клиент как бы меняются ролями.
И снова об WebBrowser
В нашем случае ActiveX нам предоставляет интерфейс IWebBrowser2 и ожидает от нас, что мы предоставим ему реализацию нотификационного интерфейса DWebBrowserEvents2 . К счастью, всю необходимую работу за нас сделал эксперт импорта ActiveX, "наследовав" TWebBrowser от TOleControl, инкапсулировав при этом IWebBrowser2 посредством соответствующих методов и свойств и реализовав обработчики для каждого метода нотификационного интерфейса.
Перед тем, как продолжить рассказ, хотелось бы обратить Ваше внимание на такой момент. Как Вы знаете, веб-документ может состоять из одного фрейма (более корректно - не иметь фреймов) или состоять из нескольких фреймов. Каждый фрейм - это тот же WebBrowser, который входит в WebBrowse более высокого уровня. WebBrowser самого верхнего уровня и есть тот AxtivX, который инкапсулируется VCL-компонентом TWebBrowser. Он как бы живет все время, пока живет TWebBrowser, тогда как WebBrowser более нижнего уровня могут динамически создаваться и уничтожатся в зависимости от того, делаем мы навигацию к много-фреймовым или к одно-фреймовым документам. Так вот, к методам WebBrowser верхнего уровня мы можем получить доступ как через методы и свойства соответствующего TWebBrowser, так и через соответствующие интерфейсные ссылки. К методам "вложенных" WebBrowser - только через интерфейсные ссылки. Интерфейсную ссылку на WebBrowser верхнего уровня можно получить через свойство TWebBrowser.ControlInterface или через TWebBrowser.DefaultInterface Получить интерфейсные ссылки на WebBrowser нижнего уровня можно посредством простого парсинга или при помощи некоторых обработчиков событий, которые сопровождают процесс навигации (но об этом ниже).
Рассмотрим вкратце сначала основные методы и свойства "от" IWebBrowser2, а затем обработчики "от" DWebBrowserEvents2 .
В первую очередь следует упомянуть метод Navigate. Этот метод дает команду WebBrowser начать навигацию к указанному ресурсу. Синтаксис этого метода следующий:
procedure Navigate( const URL: WideString; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant); overload; Здесь
URL - адресс навигации для значения Flags определены такие константы:
| navOpenInNewWindow | 1 | - открывает URL в новом окне браузера по умолчанию. То есть, в IE. Как заставить открыть URL в новом екземпляре нашего броузера я раскажу ниже при описании обработчика OnNewWindow2 |
| navNoHistory | 2 | - не заносит адрес в список History. |
| navNoReadFromCache | 4 | - не использует сохраненную в кеше страницу, а загружает с сервера. |
| navNoWriteToCache | 8 | - не записывает страницу в дисковый кеш. |
| navAllowAutosearch | 16 | - если броузер не может найти указанный домен, он передает его в поисковый механизм. |
Для передачи данных можно воспользоваться следующим фрагментом кода, который предложен Hans Gulo:
procedure TForm1.SubmitPostForm; var strPostData: string; Data: Pointer; URL, Flags, TargetFrameName, PostData, Headers: OleVariant; begin { } strPostData:='FIRSTNAME=Hans&LASTNAME=Gulo&NOTE=thats+it'; PostData := VarArrayCreate([0, Length(strPostData) - 1], varByte); Data := VarArrayLock(PostData); try Move(strPostData[1], Data^, Length(strPostData)); finally VarArrayUnlock(PostData); end; URL := 'http://127.0.0.1/cgi-bin/register.pl'; Flags := EmptyParam; TargetFrameName := EmptyParam; Headers := EmptyParam; // TWebBrowser will see that we are providing // post data and then should automatically fill // this Headers with appropriate value WebBrowser1.Navigate2(URL, Flags, TargetFrameName, PostData, Headers); end;
Важным есть property Busy . Если это свойство активно (равно True), то это свидетельствует о том, что наш АктивИкс еще не закончил загрузки страницы или выполняет некоторую команду. И может быть, что он проигнорирует новую команду. Так что в этом случае лучше подождать, когда это свойство станет равным false (или когда идет загрузка, то остановить ее можно с помощью метода Stop).
Теперь несколько слов о событиях, которые сопровождают процесс загрузки. Они, как отмечалось выше, есть своего "продолжение" соответствующих методов DWebBrowserEvents2 . Наиболее существенными из них есть (они возникают для каждого фрейма): OnBeforeNavigate2 Возникает при попытке начать навигацию. Из параметров наиболее существенным есть pDisp: IDispatch;. Этот параметр определяет броузер, который начинает навигацию. Для многофреймового документа этот броузер может не соответствовать броузеру верхнего уровня. К сожалению, этот обработчик не вызывается при вызове метода Refresh. OnNavigateComplete2 Возникает, когда попытка навигации была успешной. Наблюдение за WebBrowser позволяют сделать предположение, что это событие возникает после того, как с сервера придет первая порция данных. Документ еще продолжает загружаться. OnDocumentComplete Возникает при окончании загрузки в независимости от того, был ли документ загружен полностью или нет. К сожалению нет простого критерия для определения того, была ли страница загружена полностью или нет. Как решить єту проблему я попытаюсь рассказать в следующих статьях этого цикла. OnNewWindow2 Возникает при попытке открыть документ в новом окне. Если Вы хотите, чтобы документ был открыт в Вашем экземпляре броузера, то Вам нужно создать свой экземпляр броузера и параметру ppDisp присвоить интерфейсную ссылку на этот экземпляр:
procedure TFormSimpleWB.WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool); var newForm:TFormSimpleWB; begin newForm:=TFormSimpleWB.Create(Application); newForm.Show; ppDisp:=newForm.WebBrowser1.ControlInterface; end;
С остальными методами должно быть более-менее понятно из их названия. Если это не так - можно посмотреть уже упоминаемую статью Александра Лозовюка.
Но на остаток я хотел бы немного рассказать еще о двух свойствах, при использование которых можно немного попасть впросак.
Первым делом это TWebBrowser.Document:IDispatch . Через это свойство можно получить доступ к интерфейсу IHtmlDocument2.. Далее через этот интерфейс можно получить доступ к большинству средств по взаимодействию с загруженным документом. То есть это очень интересное и "нужное" свойство. Но немного забегая наперед, скажу, что если Вы попытаетесь использовать TWebBrowser.Document:IDispatch, то Вы рано или поздно заметите довольно странную "утечку" памяти в процессе навигации. В чем же дело? После анализа ситуации, удалось определить, что для любой интерфейсной ссылки на документ, которая получена через этот свойство, счетчик использования "необоснованно" увеличивается на 1 и соответствующий COM-обьект никогда не будет освобожден. При более детальном изучении нашлась и создательница этой проблемы - function TOleControl.GetIDispatchProp(Index: Integer): IDispatch;, через которую и работает TWebBrowser.Document:IDispatch (я речь веду о Delphi5, возможно в Delphi4 все нормально, не проверял). Детальный рассказ об этой ситуации выходит за рамки этой статьи..
К счастью эту проблему легко обойти, использовав для получения IHtmlDocument2 альтернативные возможности, хотя бы WebBrowser1.ControlInterface.Document .
Также хочется упомянуть о property LocationURL: WideString; Как утверждается в вышеупомянутой статье Александра Лозовюка , оно содержит URL ресурса, загруженного в браузер. Того же мнения придерживается и контекстная справка от Delphi5. Мало того - об этом также говорится в - во всяком случае так было на момент написания статьи ...
Но это не совсем так. Дополним наш "шедевр" обработчиком события окончания загрузки документа:
implementation {$R *.DFM} uses mshtml; procedure TFormSimpleWB.WebBrowser1DocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant); begin // Caption:=WebBrowser1.LocationURL+' '+ ((pDisp as IWebBrowser).Document as IHtmlDocument2).URL; end;
Обратите внимание на включение модуля mshtml, который позволяет использовать функциональность mshtml.dll.
Перед тем как продолжить рассказ я снова вынужден сделать маленькое отступление в сторону COM.
Обратите внимание, как имея в руках интерфейс типа IDispatch от броузера (параметр pDisp), который закончил загрузку документа (это можно подсмотреть в описании события DocumentComplete в MSDN ), мы посредством "as" получаем интерфейс типаbIWebBrowser на тот же объект (здесь имеем неявный вызов QueryInterface). Этот интерфейс при помощи свойства Documentпbозволяет нам получить интерфейс IHtmlDocument2 к загруженому документу. И вот в конце-концов через этот интерфейс мы можем обратится к интересующему нас свойству URL , которое и возвращает адрес того ресурса, который в действительности загружен в браузер (а property LocationURL говорит только о том, что мы броузеру сказали загружать). Да, нам еще не раз придется продиратся через такие дебри интерфейсов, свойств и запросов. И что наиболее печально - MSDN не всегда внятно говорит где и от кого можно запросить интересующий нас интерфейс ... Также на первых порах вызывает недоумение тот факт, почему тот же IWebBrowser.Document есть типа IDispatch, а не хотя бы тот же IHtmlDocument2. Но это довольно легко понять, если вспомнить во первых, что WebBrowser позволяет работать с ним разного рода скриптовым языкам, а во вторых, что интерфейс IDispatch позволяет вызывать свойства и методы по имени (что собственно и делают скриптовые языки). В принципе, мы бы также работать в Delphi с WebBrowser в стиле скриптовых языков, но я сознательно не привожу примеров такого подхода, так как он чреват возникновением разного рода ошибок, которые можно будет обнаружить только во время выполнения (и которые отсеиваются на этапе компиляции при использовании "нормальных" интерфейсов).
Но довольно теории - сделаем маленький эксперимент: запустим "шедевр" на выполнение и дадим команду навигации на заведомо отсутствующий ресурс. И что же мы видим:
Взглянем на заголовок окна нашей формы - до символов есть значение, которое возвращает property LocationURL , после - действительный адрес того ресурса, который отображается браузером по окончании загрузки.
Прошу понять меня правильно - этот пример я привел с целью еще один раз показать, что даже в фирменных материалах бывают неточности ... К сожаленью, такие неточности нам обходятся иногда очень дорого ...
| Простой парсинг |
Использование Interenet-функций Win32® API
| Раздел Подземелье магов |
Internet так сильно вошел в нашу жизнь, что программа, так или иначе не использующая его возможности, обречена на “вымирание” почти как динозавры. Поэтому всех программистов, вне зависимости от квалификации и специализации так и тянет дописать до порой уже готовой программы какой-то модуль для работы с Internet. Но тут и встает вопрос – как это сделать? Давайте рассмотрим, что нам предлагает среда Borland Delphi и Win32 API.
Во-первых, можно использовать компоненты с вкладки FastNet. Все они написаны фирмой NetMasters и поставляются без исходного кода. По многочисленным откликам различных разработчиков можно сказать, что большинство из них не выдерживает никакой критики, особенно “отличились” компоненты для работы с почтой. Большинство проблем можно было бы исправить, но так как исходные тексты закрыты, то это вряд ли удастся. Даже если вы будете использовать такие вроде бы надежные компоненты как TNMHTTP, TNMFTP, то в случае распространения готовой программы перед вами встает проблема: для полноценной работы программа с этими компонентами требует наличия ряда динамических библиотек. Значит, их надо отыскать, потом поставлять вместе с приложением, копировать в системные папки… Короче говоря, все слишком запутано.
Если вам не требуется всей функциональности этих компонент, например, надо только реализовать функции GET или POST протокола HTTP, то можно поискать на сайтах с компонентами, вроде torry.ru – там обязательно сыщется много различных библиотек, по большей части бесплатных, и с исходным кодом.
Но зачем нам что-то использовать, когда есть доступ к Win32 API ? Если приглядеться, то все эти компоненты всего лишь оболочка для вызова функций более низкого порядка. А раз так, то можно сразу их использовать. Кроме полного контроля над реализацией сетевых функций вы будете иметь и более компактный и быстрый код, так как устраняется прослойка между программой и API. Так что же такое Internet- функции Win32 API?
| Все Internet- функции разбиты на категории: |
Всего функций довольно много, около 80, но для средних приложений большинство из них не понадобится. Рассмотрим, что можно использовать из первой категории.
Из всех функций наибольший практический интерес представляют следующие:
| InternetCheckConnection |
Синтаксис:
function InternetCheckConnection(lpszUrl: PAnsiChar; dwFlags: DWORD; dwReserved: DWORD): BOOL; stdcall; Если нужно проверить, есть ли соединение по конкретному URL, то параметр lpszUrl должен содержать нужный URL; если интересует, есть ли соединение вообще, установите его в nil.
| К сожалению, я не проверял эту функцию, когда писал статью... а жаль... вот что получаеться: константа FLAG_ICC_FORCE_CONNECTION вообще не описана в Дельфи. более того - ее нет ни в Microsoft Visual C++ 5 (!!!!), VBasic 5 тоже! едва нашел в C++ Builder 5. Вот описание - const FLAG_ICC_FORCE_CONNECTION $00000001 Но! Даже с описанной константой ничего не работает так, как надо! Вот пример: procedure TForm1.Button1Click(Sender: TObject); var h:boolean; begin h:= wininet.InternetCheckConnection(nil,$00000001,0); if h = True then Label1.Caption:='Соеденение с сервером 127.0.0.1 установлено.' else if h = false then Label1.Caption:='Соеденения с сервером 127.0.0.1 нет.'; end; Запускаю вместе с сервером - вроде должно пинговать его. Но первый раз функция показывает что соеденение есть несмотря на то, стоит ли сервер, или нет. Потом все время выдает false. Если кто из читателей может пролить некоторый свет на проблему этой функции, очень прошу написать мне. Благодарю Суркиза Максима, который впервые обратил мое внимание на проблему. |
| InternetOpen |
Функция возвращает значение TRUE, если компьютер соединен с Internet, и FALSE - в противном случае. Для получения более подробной информации о причинах неудачного выполнения функции вызовите GetLastError, которая возвратит код ошибки. Например, значение ERROR_NOT_CONNECTED информирует нас, что соединение не может быть установлено или компьютер работает в off-line.
Далее рассмотрим одну из самых важных функций. Ее вы будете использовать всякий раз, когда нужно получить доступ к любому из серверов – будь то HTTP, FTP или Gopher. Речь идет о InternetOpen .
Синтаксис:
function InternetOpen(lpszAgent: PChar; dwAccessType: DWORD; lpszProxy, lpszProxyBypass: PChar; dwFlags: DWORD): HINTERNET; stdcall;
Параметры:
lpszAgent – строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос. dwAccessType - задает необходимые параметры доступа. Принимает следующие значения:
Непосредственно с этой функцией связанна и еще одна, не менее важная: InternetCloseHandle.
| InternetCloseHandle |
function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall; Как единственный параметр, она принимает указатель, полученный функцией InternetOpen, и закрывает указанное соединение. В случае успешного закрытия сессии возвращается TRUE, иначе - FALSE. Если поток блокирует возможность вызова Wininet.dll, то другой поток приложения может вызвать функцию с тем же указателем, чтобы отменить последнюю команду и разблокировать поток.
Мы уже установили соединение и знаем, как его закрыть. Теперь нам нужно соединиться с конкретным сервером, используя нужный протокол. В этом нам помогут следующие функции:
| InternetConnect |
Итак, мы имеем связь с сервером, нужный нам порт открыт. Теперь следует открыть соответствующй файл. Для этого определена функция InternetOpenUrl. Она принимает полный URL файла и возвращает указатель на него. Кстати, перед ее использованием не нужно вызывать InternetConnect.
| InternetOpenUrl |
Синтаксис:
function InternetOpenUrl(hInet: HINTERNET; lpszUrl: PChar; lpszHeaders: PChar; dwHeadersLength: DWORD; dwFlags: DWORD; dwContext: DWORD): HINTERNET; stdcall;
Параметры:
Теперь можно спокойно считывать нужный файл функцией InternetReadFile.
| InternetReadFile |
function InternetReadFile(hFile: HINTERNET; lpBuffer: Pointer; dwNumberOfBytesToRead: DWORD; var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall;
Параметры:
После завершения работы функции нужно освободить указатель Hfile, вызвав InternetCloseHandle(hUrlFile) .
Вот, в принципе, и все об самых основных функциях. Для простейшего приложения можно определить примерно такой упрощенный алгоритм использования Internet- функций Win32 API взамен стандартным компонентов. HSession:= InternetOpen - открывает сессию. HConnect:= InternetConnect - устанавливает соединение. hHttpFile:=httpOpenRequest HttpSendRequest - HttpOpenRequest и HttpSendRequest используются вместе для получения доступа к файлу по HTTP- протоколу. Вызов HttpOpenRequest создает указатель и определяет необходимые параметры, а HttpOpenRequest отсылает запрос HTTP серверу, используя эти параметры. function HttpOpenRequest(hConnect: HINTERNET; lpszVerb: PChar; lpszObjectName: PChar; lpszVersion: PChar; lpszReferrer: PChar; lplpszAcceptTypes: PLPSTR; dwFlags: DWORD; dwContext: DWORD): HINTERNET; stdcall; function HttpSendRequest(hRequest: HINTERNET; lpszHeaders: PChar; dwHeadersLength: DWORD; lpOptional: Pointer; dwOptionalLength: DWORD): BOOL; stdcall; HttpQueryInfo – используется для получения информации о файле. Вызывается после вызова HttpOpenRequest. function HttpQueryInfo(hRequest: HINTERNET; dwInfoLevel: DWORD; lpvBuffer: Pointer; var lpdwBufferLength: DWORD; var lpdwReserved: DWORD): BOOL; stdcall; InternetReadFile - считывает нужный файл. InternetCloseHandle(hHttpFile) – освобождает указатель на файл. InternetCloseHandle(hConnect) - освобождает указатель на соединение. InternetCloseHandle(hSession) - освобождает указатель на сессию. Объем статьи не позволяет подробно рассмотреть все множество функций, предоставляемых Win32 API. Это введение показало вам только вершину айсберга, а дальше дело за вами – внутренний мир WinAPI очень богат и большинство из того, что обеспечивают сторонние компоненты, можно отыскать в его недрах.
Удачи вам!
Специально для
апрель 2001 г.
Новое поколение выбирает... MatrixWB -
Использование интерфейсов ComAdmin
В ряде случаев разработчику необходимо проводить операции по управлению MTS автоматически, без участия пользователя. Оказывается, что все это можно сделать с помощью библиотеки COMAdmin_TLB (\system32\Com\comadmin.dll) (Рисунок 2). Кстати и сама утилита Component Services представляет собой лишь интерфейс для управления данной dll.
Как видим, библиотека предоставляет нам три интерфейса: ICOMAdminCatalog, ICatalogCollection, ICatalogObject.
Первый из них позволяет создать экземпляр объекта, который и предоставит нам все те возможности, что реализует утилита Component Services.
Использование компилятора Delphi (dcc32.exe) в прикладных программах
| Раздел Подземелье магов | й Гурин, дата публикации 13 сентября 2001г. |
| игорьев, дата публикации 01 декабря 2003г. |
Программа Canvas2 предназначена для демонстрации возможностей Windows по рисованию кривых Безье. Программа включает в себя следующие возможности:
При подготовке программы основным источником информации по кривым Безье была книга Фень Юань - СПб.: Питер, 2002
Главное окно программы позволяет пользователю рисовать кривые Безье в интерактивном режиме. При нажатии и удерживании левой кнопки мыши на форме за курсором начинает тянуться прямая линия. После отпускания кнопки на линии появляются четыре красных квадратика. Два из них обозначают начало и конец линии, два - опорные или промежуточные точки. Пользователь может перетаскивать эти квадратики, ухватив за них мышью. Также можно менять стиль линии с помощью группы зависимых кнопок, расположенной в левом верхнем углу окна. Ниже находится другая группа кнопок, указывающая, как будут интерпретироваться дополнительные точки: как опорные или как промежуточные. Опорные точки вместе с концевыми задают касательные к кривой в её концах. В общем случае эти точки не принадлежат кривой. Промежуточные точки принадлежат кривой. По двум концевым и двум промежуточным или по двум опорным точкам можно однозначно построить кривую Безье. Кнопка "Завершить" "впечатывает" текущую кривую в картинку в том виде, в каком она в данный момент представлена на экране. После этого кривую больше нельзя изменять, но можно нарисовать новую кривую.
Использование пятого "постулата" Дейта.
| Раздел Подземелье Магов |
Словарь данных
СУБД должна обеспечивать функции словаря данных.
Сам словарь данных можно по праву считать базой данных
(но не пользовательской, а системной). Словарь содержит "данные о данных"
иногда называемые метаданными, т.е. определения других обьектов системы...
Введение в системы баз данных. К.Дж. Дейт
В этой статье я попробую показать один из возможных способов использования метаданных СУБД в одном конкретном случае.
Входные данные: Существует БД, функционирующая на 2-х серверах (Interbase 6.0, Oracle 8), естественно существуют различия в физической реализации, но состав таблиц и полей идентичны. Следует заметить, что при генерации БД для Interbase для описания полей использовались домены (пользовательские типы данных), в то время как для Oracle, не поддерживающего домены, при генерации полей тип данных указывался явно. Ниже представлены два скрипта для одного и того же обьекта БД.
| InterBase | Oracle |
| create table KLSTYPE ( ID_KLSTYPE D_PK_DM not null, IDDEP_KLSTYPE D_PK_DM , NAME_KLSTYPE D_NAME_FULL_DM not null, SHORTNAME_KLSTYPE D_NAME_SHORT_DM , TYPE_KLSTYPE D_SMALLINT_DM , constraint PK_KLSTYPE primary key (ID_KLSTYPE) ); | create table KLSTYPE ( ID_KLSTYPE VARCHAR(10) not null, IDDEP_KLSTYPE VARCHAR(10) null , NAME_KLSTYPE VARCHAR2(100) not null, SHORTNAME_KLSTYPE VARCHAR2(45) null , TYPE_KLSTYPE number(5,0) null , constraint PK_KLSTYPE primary key (ID_KLSTYPE) )/ |
Использование доменов для Interbase оказалось достаточно удобным :). Предположим у нас есть домен описывающий Статус обьекта предметной области определенный на интервале -2 до 15. Ниже приведено описание такого домена. create domain D_STATUS_DM as SMALLINT default 0 check (value between -2 and 15); Предположим нам необходимо расширить интервал статусов или вообще снять ограничение на статусы. В случае Interbase команда DDL выглядит достаточно просто: ALTER DOMAIN D_STATUS_DM DROP CONSTRAINT; Для СУБД ORACLE не все так просто, в общем случае нам необходимо просмотреть все таблицы и найти все поля хранящие статусы и сформировать, а затем выполнить соответствующую команду ALTER TABLE ..... Существует альтернативный вариант - использование CASE средств, но к моему великому сожалению, используемый нами Sybase Power Designer 6.0 не умеет требуемого, в последующих версиях 7,8 появилась возможность сравнения физических моделей, но прослеживается нехорошая тенденция вместо генерации скрипта ALTER выполнять полное убиение таблицы и создания новой. Т.е. использование CASE средств не спасает в подобном случае, хотя дает возможность определить обьекты использующие определенные домены.
Теперь хорошие новости: У нас есть информация о том какие таблицы и какие поля используют данный домен в БД Interbase. Нам просто остается найти ее и использовать. Ниже приведен скрипт извлекающий из "словаря данных" Interbase необходимую информацию: SELECT RDB$FIELD_NAME, RDB$RELATION_NAME FROM RDB$RELATION_FIELDS WHERE (RDB$FIELD_SOURCE = 'D_STATUS_DM')
В результате выполнения запроса мы получили список таблиц и полей использующих наш домен D_STATUS_DM. И что дальше? Опять ручная работа? К счастью, нет. (здесь надо сделать следующее замечание: поскольку генерация БД велась с использованием CASE средства, то имена констраинтов для оракла могут быть сформированы из имени таблицы и поля :). т.е. к примеру для таблицы OBJ содержащей поле STATUS_OBJ был сформирован констраинт с именем CKC_STATUS_OBJ_OBJ.). Формируем запрос для удаления старых ограничений на поля использующие наш домен: SELECT 'ALTER TABLE ' trim(RDB$RELATION_NAME) ' DROP constraint ' 'CKC_' trim(RDB$FIELD_NAME) '_' trim(RDB$RELATION_NAME) ' ;' FROM RDB$RELATION_FIELDS WHERE (RDB$FIELD_SOURCE = 'D_STATUS_DM')
Итак результатом нашего запроса является скрипт практически готовый для исполнения. Что же с ним делать? Если вы используете для работы isql.exe вы можете создать файл, к примеру fordropckc.sql, со следующим текстом: set names win1251; CONNECT "myhost:d:\sqlbase\TERRA_new.GDB" user "sysdba" password "masterkey"; SELECT cast('ALTER TABLE ' trim(RDB$RELATION_NAME) ' DROP constraint ' 'CKC_' trim(RDB$FIELD_NAME) '_' trim(RDB$RELATION_NAME) ' ;' as varchar(100)) FROM RDB$RELATION_FIELDS WHERE (RDB$FIELD_SOURCE = 'D_STATUS_DM'); после выполнения данного файла с помощью командной строки "c:\Program Files\Borland\InterBase\bin\isql.exe" -e -s 1 -input fordropckc.sql -output Result.txt -m Мы получим текстовый файл Result.txt из которого можно сравнительно легко (любым текстовым редактором) можно получить необходимый нам скрипт: ALTER TABLE ADMUSERS DROP constraint CKC_STATUS_ADMUSERS_ADMUSERS ; ALTER TABLE OBJ DROP constraint CKC_STATUS_OBJ_OBJ ; ALTER TABLE MTDENT DROP constraint CKC_NEWSTAT_MTDENT_MTDENT ; ........
Если Вы используете какое-нибудь средство администрирования, к примеру IBExpert, то вы можете просто сохранить результат запроса в файл или скопировать его в буфер обмена. Полученный скрипт готов к выполнению.
Аналогичным образом можно сформировать скрипт для создания новый ограничений.
Естественно, данный пример ни в коем случае не может претендовать на полное освещение темы "словарь данных в СУБД", но приведеный пример можно рассматривать как "привычность мысли надо гнать, столовый нож оружьем может стать" :)
Благодарности:
Max Rezanov.
февраль 2002г.
Использование СOM в среде Delphi
Последнее время много внимания уделяется построение систем электронного бизнеса, или как их еще назыают - B2B (business to business). Учитывая рекомендации по построению обменных потоковых систем координирующего интернет-технологий органа - WWW Consortium: акцент сделан в сторону XML-технологий и построение систем обмена XML-документами.Преимущество использования XML в электронном бизнесе - высокая эффективность B2B систем при низких затратах на ее создание за счет четкого и наглядного представления структурированной информации, возможность использования современных сетевых протоколов и создания бизнес-систем реального времени.
Независимость представления информации в виде XML документов позволяет разным, участвующим в электронном бизнесе, фирмам производить независимое друг от друга ПО.
Во всех системах обмен, как правило, строится по одинаковой схеме, с использованием HTTP запросов. В качестве протокола защиты информации применяется протокол SSL (но это отдельная тема).
Один из возможных вариантов обработки XML сообщения является построение BIN/CGI (ISAPI)-приложений или COM (серверных) компонент, формирующих или обрабатывающих XML-документы.
С одной стороны, приложение выступает в качестве клиента, которое в режиме POST выдает HTTP запрос, с другой стороны, находится WEB сервер на стороне которого осуществляется обработка запроса и выдача ответа. В информационном обмене используются XML-документы.
Один из наиболее эффективных вариантов реализации - использование существующего XML-парсера, поддерживающего DOM модель. Такой парсер является дистрибутивной поставкой Win`98 или составной частью IE 4,7 и выше (для Win`95) и представляет COM сервер, находящийся в библиотеке msxml.dll.
Модель компонентных объектов (COM) - представляет инкапсулированные данные и методы в единую сущность и способ доступа к ним через систему интерфейсов. Средствами Delphi достаточно просто осуществить доступ к классам COM-объекта (в одном COM-сервере может быть включено несколько классов). Доступ к объектам осуществляется путем инициализации экземпляра класса через систему интерфейсов. Описание интерфейсов осуществляется языком определения интерфейсов (IDL), которое возможно осуществить средствами среды автоматически.
Средствами Delphi осуществляется импорт из COM-сервера msxml.dll, строится файлы описания интерфейса IDL и файл бинарноого описания типов библиотеки - TLB. Данная операция осуществляется через системное меню: Project | Type Library Import… (рис 1). Далее появляется диалоговое окно (рис 2), в котором необходимо выбрать COM-объект (в нашем случае объект зарегистрирован под именем "Microsoft.XMLDom (Version 2.0)" ) и создать TLB-файл (кнопка Create Unit). Используя TLB-файл, среда генерирует "паскалевский" файл описания COM-сервера - MSXML_TLB.pas
 |
 |
| Рис 1 |
Рис 2 |
Для доступа к объектам COM-элемента, необходимо в директиве USES добавить имя файла описания библиотеки (MSXML_TLB.pas). Ниже представлена простейшая программа, использующая DOM стандартный анализатор msxml.dll, которая загружает XML-документ и отображает его в элементе текстового поля Memo1.
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, OleServer, MSXML_TLB, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; procedure Button1Click(Sender: TObject); end; var Form1: TForm1; implementation {$R *.DFM} Procedure TForm1.Button1Click(Sender: Tobject); var coDoc : CoDOMDocument; /* объявление сокласса объекта DOMDocument; */ var Doc: IXMLDOMDocument; /* класс, согласованный с интерфейсом IDOMDocument; */ begin Doc := coDoc.Create; /* создание экземпляра объекта DOMDocument; */ Doc.load('data.xml'); /* вызов метода Load экземпляра объекта DOMDocument; */ Memo1.Text:=Doc.xml; /* доступ к свойстве xml экземпляра объекта DOMDocument; */ end; end.
Использование XML в среде Delphi
| Раздел Подземелье Магов | Автор А.Календарев, дата публикации 27 августа 2001 г. |
Данная статья является переработанным вариантом материалов по XML-технологии опубликованных на сайте автора
Итак, поехали!
Создадим подкаталог для объявления функций PGPsdk, скопировав туда файлики DELPHI PGP API - pgp*.pas и spgp*.pas. Удалим в файлах spgp*.pas - "stdcall;export;"(уже полученные в итоге заголовочные файлы можно взять тут [12]). Теперь к Вашему проекту нужно приписать использование библиотек (это там где uses):| uses // PGPsdk pgpEncodePas, pgpOptionList, pgpBase, pgpPubTypes, pgpUtilities, pgpKeys, pgpErrors, // SPGP spgpGlobals, spgpEncrypt, spgpKeyUtil, spgpUtil, spgpKeyMan, spgpPreferences, spgpKeyProp, spgpKeyIO, spgpKeyGen, spgpMisc, spgpUIDialogs, // always last pgpSdk; |
Можно использовать только необходимые модули.
Первое что мы попробуем сделать - это зашифровать и подписать произвольный файл и получить зашифрованный в текстовом виде (ASC). Здесь следует отметить что PGPsdk может работать не только с файлами, но и с памятью, а также комбинировать - память - файл, файл - память.
| PGPCheckResult ( 'Ошибка при шифровании файла', spgpencodefile( PChar(edtFileIn.Text), PChar(edtFileOut.Text), 1, // Encrypt.Value 1, // Sign.Value kPGPHashAlgorithm_MD5, 0, kPGPCipherAlgorithm_CAST5, 1, 0, 0, 'Steven R. Heller', // Кто может расшифровать 'Evgeny Dadgoff', // Чем подписывать 'MyPassPhrase', // Хех, это пароль '', PChar(edtComment.Text) ) ); |
Сравним что получится если переделать пример [9,стр. 18] на Delphi - на чистом API.
Лично для меня проще было использовать spgp-модель чем тяжелые PGPAPI вызовы.
Про преференс.
Для работы библиотеке необходимо знать где лежат файлы с ключиками (pubring.prk и secring.prk). PGP API позволяет сохранять свои настройки в файле PGPsdk.dat (почему то он всегда сохраняется в каталоге с виндами). Для работы с этим файлом предназначены следующие функции: spgpgetpreferences(Prefs: pPreferenceRec; Flags: Longint):LongInt; spgpsetpreferences(Prefs: pPreferenceRec; Flags: Longint):LongInt; Соответственно для получения преференса и установки его (кстати ключики могут лежать не только в файлах). Замечу что это не единственный способ – PGP API позволяет напрямую указывать где расположены ключи, но тогда Вам придется отказаться от SPGP, или поправлять SPGP под себя.
Как получить список всех имеющихся ключей
Здесь я покажу как получить список всех ключей - заполнение LVKeys:TListView именами ключей и шестнадцатеричными ID-значениями ключей, используя SPGP-модель.
| Var P : TPreferenceRec; Flags : LongInt; outBuf : array [1..30000] of Char; i,KeyCount : Integer; TempStr,StrKeys : AnsiString; Begin LVKeys.Items.Clear; FillChar(P,1024,0); FillChar(outbuf,30000,0); Flags:= PGPPrefsFlag_PublicKeyring or PGPPrefsFlag_PrivateKeyring or PGPPrefsFlag_RandomSeedFile; if(spgpGetPreferences(@P, Flags)<>0) then ShowEvent('Error!',1); // GetWindowsDirectory if(LowerCase(WinDir+'pubring.pkr')=LowerCase(StrPas(P.PublicKeyring)))or not(FileExists(StrPas(P.PublicKeyring))) then Begin StrPCopy(P.PublicKeyring, ExtractFilePath(Application.ExeName)+'KEYS\pubring.pgp'); StrPCopy(P.PrivateKeyring, ExtractFilePath(Application.ExeName)+'KEYS\secring.pgp'); StrPCopy(P.RandomSeedFile, ExtractFilePath(Application.ExeName)+'KEYS\randseed.bin'); if (CreateDir(ExtractFilePath(Application.ExeName)+'KEYS')) Then ShowEvent('Каталог ключей '+ExtractFilePath(Application.ExeName)+'KEYS'+ ' -- не существует, Будет создан заново... ',0); spgpSetPreferences(@P, Flags); //Создать файлы с ключами - такой хитрый прием. spgpSubKeyGenerate('mmmh', 'sssl', 'ssss', 1, 1024, 0, 0, 0, 0); End; btnPubKeys.Caption:=StrPas(P.PublicKeyring); btnSecKeys.Caption:=StrPas(P.PrivateKeyring); btnRndBin.Caption:=StrPas(P.RandomSeedFile); PGPCheckResult('Ошибка при инициализации PGP-SDK, убедитесь что все DLL установленны правильно', Init(FContext, PubKey, false, false)); spgpKeyRingID(@outBuf, 30000); KeyCount:=spgpkeyringcount; StrKeys:=StrPas(@outBuf); for i:=1 to KeyCount do Begin TempStr:=Copy(StrKeys,1,Pos(#13+#10,StrKeys)); Delete(StrKeys,1,Pos(#13+#10,StrKeys)+1); with(LVKeys.Items.Add)do Begin Caption:=Copy(TempStr,14,Length(TempStr)-14); SubItems.Add(TempStr[1]); SubItems.Add(Copy(TempStr,3,10)); End; End; QuitIt(FContext, PubKey); End; |
Вступление.
Я много видел разных стран..., но это для того, чтобы сказать, что я все-таки зауважал корпорацию Microsoft, после подробного знакомства с Линукс-ом. И вот почему. Операционная система Windows - наиболее простая и доступная для пользователей, кто не посвятил свою жизнь компьютеру. Ни в одной коммерческой, а тем более бесплатной, системе нет настолько простых и доступных элементов настройки как в Windows. И это только моя точка зрения. Я не хочу разводить дебаты на эту тему, потому, что хочу рассказать о своих наработках и исследованиях. Они касаются, по моему мнению, одной из лучших и развитых локальных баз данных - Microsoft Jet или mdb. При определенных усилиях можно написать даже неплохую сетевую программу на базе mdb.
Зачем это нужно?
За годы моей работы с mdb (около 6 лет) я один раз столкнулся с ситуацией, когда базу данных Access не удалось восстановить после внезапного отключения питания (Об UPC-ах и речи не было). Да и необходимость восстановления возникала всего раз 5. К тому же, поддержка Jet встроена в Windows, и нет необходимости искать (покупать) и устанавливать драйвер для базы данных. Все остальные форматы более подвержены разрушению, или состоят из множества файлов; при отсутствии одного из этих файлов говорить о целостности данных сложновато. Я готов обсудить этот факт.
О чем речь?
Речь идет о том, что базой данных mdb можно прекрасно пользоваться, не имея MS Office и Access. Все данные, необходимые для хранения и изменения информации можно хранить в mdb базе данных имея Delphi и подключенный ActiveX ADO и ADOX. Все эти компоненты поставляются с Windows, и вам не нужно приобретать MS Office только для того, чтобы сохранять таблицы и запросы к ним (и не только к ним :-) ) в базе данных mdb. Подробную справку по ADO, ADO MD и ADOX можно получить в составе (13379 Kb), хотя я скачал этот пакет только ради документации. Где-то, летом 2002 года я поставил перед собой задачу - может ли простой программист уйти от использования крякнутых программ (мне было бы обидно за свою 2-3-х летнюю работу, если бы ее крякнули ;)) и пользоваться тем, что дают бесплатно, или за доступные деньги. Так что я пришел к выводу – можно. В настоящий момент у меня уже есть довольно приличное приложение (собственной разработки), которое я использую вместо Access. В базе данных mdb понятия запрос и процедура различны, но для простоты изложения я буду использовать термин запрос.
История.
Начал с простого окна, в котором было TMemo - для текста запроса, и кнопка для выполнения этого запроса. CheckBox - для указания, возвращать мне результат запроса, или нет. Второе окно открывалось с DBGrid-ом, в котором был результат выполнения запроса. Третье окно - ListBox, который содержал список таблиц и запросов базы данных (макросы, отчеты и формы Access я не умею доставать и сейчас, даже не знаю где это прячут). По двойному щелчку на элементе списка открывалось все то-же окно с DBGrid-ом, где можно было посмотреть содержимое таблицы или запроса.
Первую базу данных я создал с помощью системного менеджера ODBC - там есть такая возможность! Первые таблицы приходилось создавать с помощью инструкций SQL. Я был приятно удивлен, что Access умеет через SQL такие вещи, которые нигде в справке по Access не описаны. К этим возможностям относится параметр DEFAULT в инструкции CREATE TABLE. В справке к Access о нем нет ни слова! А в справке по InterBase – есть. Я попробовал – очень прекрасно устанавливаются значения по умолчанию для поля создаваемой таблицы. Короче говоря, кто ищет – найдет. Первые запросы и процедуры приходилось сохранять в текстовом виде, чтобы после корректировки удалить из базы данных сохраненный запрос и внести откорректированный. Потом я попытался достать текст запроса из базы данных через ADO – не получилось, не получилось и до сих пор. Пришлось выбрать другой путь. Если это делает Microsoft – почему не могу это делать я?
Так вот, если посмотреть в системные таблицы, то там есть вся необходимая информация (или почти вся). Используя ее можно написать парсер, который будет собирать текст запроса, используя формат записи самой Microsoft. А сохранить потом измененный запрос (помним: или процедуру) с помощь инструкции CREATE VIEW или CREATE PROCEDURE.
Формат хранения SQL запроса в Access.
Сразу оговорюсь, что все это возможно только с правами администратора на базу данных (Еще один плюс в пользу Access).
Ниже привожу таблицу с описанием всего, что мне удалось раскопать по этому поводу. Используя эту информацию, я написал парсер, который собирает это все в текст запроса. Я не претендую на полноту изложения, потому, что еще не полностью разобрал эту информацию, но возможно это поможет кому-то. Буду рад помощи, если кто что-то знает по этой теме. По крайней мере процентов 70 запросов расшифровываются и выполняются так как было задумано.
Соглашения по обозначениям: Если что-то не описано – я не разбирался – не было необходимости, или не наводило на мысль.
| Connect | Database | DateCreate | DateUpdate | Flags | ForeignName | Id | Lv | LvExtra | LvModule | LvProp | Name | Owner | ParentId | RmtInfoLong | RmtInfoShort | Type |
| 01.10.2003 16:43:35 | 16.10.2003 15:26:43 | 0 | 447 | (Blob) | (Blob) | (Blob) | (Blob) | r_Cash | (VarBytes) | 251658241 | (Blob) | (VarBytes) | 1 |
Из этой таблицы мне пригодились всего два параметра – Id и Name. Имя запроса мне известно, а все записи в другой системной таблице, относящиеся к этому запросу я нахожу при помощи поля Id.
2.Внешний вид записей, относящихся к одному запросу в таблице MSysQueries (в ней хранится структура всех запросов и процедур).
| Attribute | Expression | Flag | LvExtra | Name1 | Name2 | ObjectId | Order |
| 0 | 0 | -2147483636 | (VARBYTES) | ||||
| 255 | -2147483636 | (VARBYTES) | |||||
| 5 | Staff_list | -2147483636 | (VARBYTES) | ||||
| 5 | Personal | -2147483636 | (VARBYTES) | ||||
| 6 | [Staff_list].[P_code] | 0 | -2147483636 | (VARBYTES) | |||
| 6 | [Staff_list].[Name] | 0 | -2147483636 | (VARBYTES) | |||
| 6 | [Staff_list].[Br] | 0 | -2147483636 | (VARBYTES) | |||
| 6 | [Staff_list].[Room] | 0 | -2147483636 | (VARBYTES) | |||
| 6 | [Personal].[Fam] | 0 | -2147483636 | (VARBYTES) | |||
| 7 | [Staff_list].[Room]=[Personal].[Room] | 2 | Staff_list | Personal | -2147483636 | (VARBYTES) | |
| 7 | [Staff_list].[Br]=[Personal].[Br] | 2 | Staff_list | Personal | -2147483636 | (VARBYTES) | |
| 7 | [Staff_list].[P_code]=[Personal].[P_code] | 2 | Staff_list | Personal | -2147483636 | (VARBYTES) |
3. Описание полей и их значений относящихся к запросу (процедуре).
| Формат хранения запросов в Access (MsysQueries) Значение ObjectID и имя запроса находится в таблице MsysObjects | |||||
| Поле | Значение | Описание | СубПоле | Значение | Описание |
| Attribute | 0 | Разделитель запросов | ObjectID | [LongInt] | Этот же ID содержится во всех остальных записях, относящихся к этому запросу |
| 255 | Пустая запись (я не встречал ее заполненой) | Идет после Attribute 0 всегда | |||
| 1 | Тип запроса, определяется полем Flag. Присутствует не всегда. Если запись отсутствует, то это (скорее всего, да других вариантов и не встречалось) запрос SELECT | Flag | 1 | SELECT ... FROM | |
| 2 | INSERT ... INTO | ||||
| 3 | UPDATE ... SET | ||||
| 4 | UPDATE ... SELECT | ||||
| 5 | DELETE | ||||
| 6 | TRANSFORM | ||||
| 7 | MODIFY, CREATE TABLE, DROP | ||||
| 8 | |||||
| 9 | UNION | ||||
| 10 | |||||
| 11 | EXECUTE | ||||
| Expression | [Text] | Параметры для Execute | |||
| [Text] | Текст процедуры для Flag=7 | ||||
| Name1 | [Text] | Имя процедуры для Execute | |||
| 2 | Параметры запроса | Flag | 1 | Bit (boolean по Delphi) | |
| 2 | Byte (Tinyint) | ||||
| 3 | Short (SmallInt) | ||||
| 4 | Integer | ||||
| 5 | Currency | ||||
| 6 | Real | ||||
| 7 | Float | ||||
| 8 | TdateTime | ||||
| 9 | |||||
| 10 | String([LvExtra]) (Char..., Text...) | ||||
| 11 | Image !!! | ||||
| 12 | |||||
| 13 | |||||
| 14 | |||||
| 15 | UNIQUEIDENTIFIER | ||||
| 16 | Decimal | ||||
| LvExtra | [Integer] | Длина параметра для [String] и т. д. где имеет смысл | |||
| Запись с аттрибутом 3 я так и не разобрал, это только ход моих размышлений. | |||||
| 3 | Предикаты (Скорее всего битовое поле) ????? | Flag | 0,1 | ALL | |
| 2 | DISTINCT | ||||
| 3 | SELECT DISTINCT * | ||||
| 4 | WITH OWNERACCESS OPTION | ||||
| 5 | Выборка * | ||||
| 8 | DISTINCT ROW ??? | ||||
| 16 | TOP | ||||
| 48 | TOP | ||||
| 4 | Внешняя база данных | Name1 | [Text] | Путь к внешней базе данных ( IN ) | |
| 5 | Исходные таблицы или текст отдельного блока для UNION | Expression | [Text] | Для UNION содержит в каждой строке текст блока UNION SELECT | |
| Для SELECT | Name1 | [Text] | Имя таблицы для выборки | ||
| Для SELECT | Name2 | [Text] | Алиас таблицы | ||
| 6 | Имя поля секции SELECT | Expression | [Text] | Имя поля | |
| Name1 | [Text] | Алиас поля { | |||
| 7 | Конструкция и тип объединения JOIN | Expression | [Text] | <Поле1>{ = | <> | > | < }<Поле2> | |
| Flag | 1 | INNER JOIN | |||
| 2 | LEFT JOIN | ||||
| 3 | RIGHT JOIN | ||||
| Name1 | [Text] | Имя или алиас Таблицы1 | |||
| Name2 | [Text] | Имя или алиас Таблицы2 | |||
| 8 | Секция WHERE | [Expression] | [Text] | Условие WHERE полностью | |
| 9 | Секция GROUP BY | [Expression] | [Text] | Условие GROUP BY полностью | |
| 10 | Секция HAVING | [Expression] | [Text] | Условие HAVING полностью | |
| 11 | Секция ORDER BY | [Expression] | [Text] | Условие ORDER BY полностью |
Всем удачи!
Шкут Александр (AlexS.)
25 декабря 2003г.
Специально для
Как работает программа
Программа использует компонент Graph, о котором я рассказывал в прошлой статье.Примечание:
Материал раздела
Сейчас я несколько улучшил этот компонент. Плюс, в нем появилось две новых функции: function ReflectData(BaseBitmap, DataBitmap: TBitmap; List: TStrings; Reflection: TReflectionProc; ScatterType: TScatterType; Factor: Integer = 1): TReflectionResult; virtual; function AssemblyData(BaseBitmap, DataBitmap: TBitmap; Assembling: TAssemblingProc): Boolean; virtual; Первая функция создает изображение, содержащее информацию; вторая - получает информацию из двух изображений, как я рассказывал выше. Параметры функции ReflectData:
Как работать с программой
Для того, чтобы создать "слепок" существующего рисунка, нужно:Команды и функции Script Language.
Основные команды и функции в компоненте реализованы с префиксом "PM_"Например // Установить текущую страницу публикации procedure PM_Page(const nPages : Integer); virtual; // Получить текущуу страницу в публикации Function PM_GetPageNumber : TPageNumber; virtual; // Получить количество страниц Function PM_GetPages : Integer; virtual; В компоненте я постарался сохранить синтаксис команд Script Language т.е команде Page Script Language соответствует PM_Page компонента. Да и еще более детальную информацию по Script Language можно прочитать в Slguide.hlp. Это позволит вам написать функции и процедуры не реализованные в этом компоненте, а может и создать свой.
Вот в принципе то и все. Удачи вам.
P.S. Хочу напоследок заметить что данный компонент не претендует на завершенность и полную функциональность , многое в нем реализовано не очень хорошо , но учитывая что он был создан для обкатки в короткие сроки то для основ работы он подойдет.Так что критика приниматься не будет.
Скачать:
Компонент для XML сериализации
| Раздел Подземелье Магов |
Содержание
Объединяя сказанное о , объектов и соберем полноценный компонент для XML сериализации.
Компонент конвертирует компонент в XML и обратно в соответствии с published-интерфейсом класса компонента. XML формируется в виде пар тегов с вложенными в них значениями. Атрибуты у тегов отсутствуют. Тег верхнего уровня соответствует классу объекта. Вложенные теги соответствуют именам свойств. Для элементов коллекций контейнерный тег соответствует имени класса. Вложенность тегов не ограничена и полностью повторяет published интерфейс класса заданного объекта. Поддерживаются целые типы, типы с плавающей точкой, перечисления, наборы, строки, символы. вариантные типы, классовые типы, стоковые списки и коллекции. Интерфейс: procedure Serialize(Component: TObject; Stream: TStream); - Сериализация объекта в XML procedure DeSerialize(Component: TObject; Stream: TStream); - Загрузка XML в объект property GenerateFormattedXML - создавать форматированный XML код property ExcludeEmptyValues - пропускать пустые значения свойств property ExcludeDefaultValues - пропускать значения по умолчанию property StrongConformity - необходимо наличие в XML соотв. тегов для всех классовых типов property OnGetXMLHeader - позволяет указать свой XML заголовок Ограничения: В объекте допустимо использовать только одну коллекцию каждого типа. Для преодоления этого ограничения требуется некоторая доработка. Наследники класса TStrings не могут иметь published свойств. Процедурные типы не обрабатываются. Для генерации DTD у объекта все свойства классовых типов, одноименные со свойствами агрегированных объектов, должны быть одного класса. Предусловия: Объект для (де)сериализации должен быть создан до вызова процедуры. При StrongConformity == true необходимо присутствие в загружаемом XML тегов для всех классовых типов. Присутствие остальных тегов не проверяется. Дополнительно: При загрузке из XML содержимое коллекций в объекте не очищается, что позволяет дозагружать данные из множества источников в один объект.
Компонента TAskExceptionHandler
После «перетаскивания» компоненты на главную форму приложения она перехватывает стандартный обработчик исключительных ситуаций и подменяет его своим. При возникновении ИС во время выполнения программы формируется новая запись в LOG-файле, содержащая следующую информацию:Компонента имеет 2 свойства:
Концепция DOM - объектная модель документа
Каждый XML документ представляется в виде набора множества объектов (классов), с помощью которых возможен доступ к отдельным элементам (полям объекта). DOM - интерфейс описывает доступ как к простым объектам типа DOMString или CharacterData, так и к частям или отдельным элементам XML документа: DOMFragmentElement, DOMNode, DOMElement.Ниже приведены самые важные свойства и методы объектов XMLDOMDocument, XMLDOMNode, XMLDOMNodeList. Необходимо отметить, что представленные ниже методы и функции объектов DOM модели (Document Object Model) используются Microsoft XML-анализатором msxml.dll и несколько шире, чем утвержденная W3C Консорциумом DOM модель.
Более полное описание интерфейса DOM объектов можно найти на www.msdn.microsoft.com/xml
| Объект XMLDOMDocument | |
| Представляет верхний уровень объектной иерархии и содержит методы для работы с документом: его загрузки, анализа, создания в нем элементов, атрибутов, комментариев и т.д. . | |
| Свойства | |
| Async | Свойство идентифицирующее текущий режим обработки |
| ParseError | Возвращает ссылку на объект обработки ошибки XMLDOMParseError |
| validateOnParse | Включение - выключение верификации документа. |
| url | Возвращает URL документа |
| documentElement | Содержит ссылку на корневой элемент документа в виде объекта XMLDOMElement. |
| Методы | |
| load(url) loadXML(xmlString) | Загружает XML документ, |
| save(objTarget) | Сохраняет XML документ в файле |
| abort | Прерывание процесса загрузки и обработки документа. |
| createAttribute (name) | Создает для текущего элемента новый атрибут с указанным именем. |
| createNode(Type, name, nameSpaceURI) | Создает узел указанного типа и названия |
| createElement(tagName) | Создает элемент документа с указанным названием. |
| createTextNode(data) | Создает текст внутри документа |
| getElementsByTagName(tagname) | Возвращает ссылку на коллекцию элементов документа с заданным именем |
| nodeFromID(idString) | Поиск элемента по идентификатору |
| Объект XMLDOMNode | |
| Объект XMLDOMNode, реализующий базовый DOM интерфейс Node , предназначен для манипулирования с отдельным узлом дерева документа. Его свойства и методы позволяют получать и изменять полную информацию о текущем узле - его тип, название, полное название, его содержимое, список дочерних элементов и т.д. | |
| Свойства | |
| nodeName, baseName | Возвращает название текущего узла. |
| prefix | Возвращает Namespace префикс. |
| dataType | Определяет тип содержимого текущего узла |
| nodeType, nodeTypeString | Возвращает тип текущего узла: |
| attributes | Возвращает список атрибутов текущего узла в виде коллекции XMLDOMNamedNodeMap. |
| text | Возвращает содержимое текущего поддерева в виде текста |
| xml | Возвращает XML-представление текущего поддерева. |
| nodeValue | Возвращает содержимое текущего узла. |
| childNodes | Возвращает список дочерних элементов в виде XMLDOMNodeList. |
| firstChild, lastChild | Возвращает первый/последний дочерний элемент |
| previousSibling ,nextSibling | Возвращает предыдущий /следующий сестринский элемент. |
| parentNode | Содержит ссылку на родительский элемент. |
| ownerDocument | Возвращает указатель на документ, в котором находится текущий узел. |
| Методы | |
| appendChild(newChild) | Добавляет текущему узлу новый дочерний элемент. |
| insertBefore(newChild, refChild) | Вставляет дочерний узел, располагая его в текущем поддереве "левее" узла, указанного параметром refChild. |
| cloneNode (deep) | Создание копии текущего элемента. |
| getAttribute (name) getAttributeNode (name) setAttribute(name, value) setAttributeNode(XMLDOMAttribute) | Доступ к атрибутам (создание, чтение, запись) объекта. Name - имя аттрибута, value - его значение. Возращает значение объект XMLDOMAttribute. |
| replaceChild(newChild, oldChild) removeChild(oldChild) | Замена объекта oldChild текущего списка дочерних объектов на newChild. Удаление объекта oldChild |
| selectNodes(patternString) selectSingleNode(patternString) | Возвращает объект XMLDOMNodeList, выбранное по шаблону поиска или первый узел |
| transformNode(stylesheet) transformNodeToObject(stylesheet, outputObject) | Назначает стилевую таблицу для поддерева текущего узла и возвращает строку - результат обработки. В качестве параметра передается ссылка на объект DOMDocument, в котором находятся XSL инструкции. |
| Объект XMLDOMNodeList | |
| Представляет собой список узлов - поддеревья и содержит методы, при помощи которых можно организовать процедуру обхода дерева. | |
| length | число элементов списка узлов |
| item(i) | Выбор i-того элемента из списка. Возвращает объект XMLDOMNode |
| nextNode() | Выбор следующего элемента в списке. |
| й Парунов, дата публикации 18 февраля 2003г. |
Недавно возникла у меня тут потребность в контроле блоков информации. В памяти сразу всплыла магическая фраза "CRC". Вроде эта CRC бывает и 16-, и 32-битной (да хоть 512-битной, но это, пожалуй, перебор). И есть понятие "контрольная сумма". Вот об этом и поговорим, не углубляясь в теорию, а упирая на практическое применение.
Вообще говоря, задача стоит так: нам из нашей информации (назовём её блоком) нужно получить число, которое однозначно идентифицирует эту информацию (назовём его хэшем). Так как блоки большие, а число маленькое, ясно, что блоков, в том числе и такой же длины, дающих то же число, очень много, гораздо больше, чем атомов в Галактике. Зачем же тогда нужно такое число? Целей может быть две:
Речь пойдёт о первом вопросе. Второй гораздо сложнее и неоднозначнее; если хотите разобраться в нём - смотрите информацию по поиску при помощи хэш-таблиц. Кстати, в большинстве случаев это наибыстрейший вариант поиска информации.
Контроль данных - вопрос древний и проработанный. Есть два основных его варианта:
А теперь скажем Основную Истину: теоретическая вероятность того, что Вам во Вселенной встретится блок с таким же хэшем, как у вашего блока, равна единице, делённой на два в степени числа разрядов хэша, независимо от того, каким из этих двух способов он посчитан (но: контрольная сумма должна считаться из порций блока того же размера. Нельзя надеяться, что надёжность 32-битной суммы _байтов_, а не двойных слов, будет приемлемой.). Это достаточно очевидно. Однако на практике встречаются различные вариации и искажения блоков: одиночные, групповые, периодические, умышленно искажённые… это уже не полностью случайные блоки. И именно на этом оселке выявляются достоинства и недостатки упомянутых способов.
Итак, если сравнивать достоверность опознания, учитывая именно искажения исходного сообщения, особенно периодические и умышленные, CRC даёт фору контрольным суммам. Например, если поменять буквы в строке, побайтная контрольная сумма этого "не заметит" - от перестановки мест слагаемых, вычитаемых, xor-ящихся данных результат не меняется. То же будет, если поменять местами два бита на расстоянии, кратном размеру байта - собственно, это одно и то же - или прирастить одну букву и уменьшить другую в случае сложения. Есть более сложные варианты контрольных сумм, но все они страдают предсказуемостью и "обходимостью".
С другой стороны, встречаются области применения, где имеются только случайные, "размазанные" (не кусочные) искажения. Особенно часто это бывает в линиях связи. В таких областях для контроля ошибок часто используются именно контрольные суммы благодаря низким затратам. Кроме того, если иметь в виду заточенность CRC под регулярные искажения, можно сказать, что искажения нерегулярные она отлавливает несколько хуже - общая-то эффективность определяется только разрядностью.
А вот для борьбы с людьми :)… вернее, для уверенной верификации информации, защищённой от изменения, применяется CRC. Это не означает, что CRC только борется с мошенничеством - это означает, что два ПОХОЖИХ блока, что часто встречается в жизни людей, CRC обработает лучше, "случайнее", с меньшей вероятностью получения одинаковых хэшей. И сообщение, защищённое CRC32, "подделать" так, чтобы не превратить сообщение в подозрительную кучу байтов (а CRC64 - и без этого условия при длине сообщения больше десятка байт), и сейчас, и в обозримой перспективе невозможно. Разумеется, хэш должен идти по защищённому каналу, иначе следует обратиться к алгоритмам необратимого шифрования, которые тут не обсуждаются, замечу лишь, что они существенно медленнее.
Приведу два модуля для вычисления CRC32 и CRC64. Последний вдвое медленнее. Алгоритм не обсуждается - обсуждать без теории там нечего: с одной стороны, всё просто, с другой - а почему так, а не иначе?.. Неразрешимое противоречие. Желающим овладеть теорией кину линки:
Лирическое отступление:
многие программисты полагают, что переписывание кода на ассемблере способно существенно улучшить скорость. В общем случае это действительно так, но не стоит забывать, что "одна голова хорошо, а две лучше". Современные компиляторы, в том числе и Delphi, знают ассемблер существенно лучше среднего выпускника вуза компьютерной специальности :), и знать ассемблер сейчас нужно, в основном, только чтобы представлять, какой код создаётся из Ваших исходников, поднимая при желании именно их скорость, а не заниматься этим "врукопашную".
Что и показано моим модулем для CRC32 - он в полтора раза быстрее ассемблерного кода й Парунов
февраль 2003г,
Специально для
Смотрите по теме:
Коротко об XSL
Абревиатура XSL происходит от eXtensible Stylesheet Language - язык форматирования таблиц стилей (XML данных). Как понятно из заголовка eXtensible Stylesheet Language (XSL) используется для форматирования XML данных. По определению W3C XSL состоит из двух частей:При помощи XSLT мы можем отобрать нужные нам данные из XML файла, и оформить их в виде для предоставления пользователю. Например, в нашем случае мы преобразовали XML данные в виде SQL запроса. Классическое применение XSL - это, как правило форматирование данных в виде HTML страниц или более редкое представление в виде RTF файлов.
XSL файл описывает шаблон (template), согласно которому будет совершаться преобразование XML данных. Возращаясь к xsl-шаблонам, в XSLT можно выделить следующие элементы (директивы):
| XSL-директивы описание | |
| xsl:apply-templates | Директива, указывающая на применение соответствующих шаблонов аттрибуту select="имя шаблона" |
| xsl:attribute | создает дерево аттрибутов и добавляет его в выходной элемент, пареметр name="имя аттрибута", namespace - URI на пространство имен (преффикс пространства имен) |
| xsl:call-template | вызывает шаблон, аттрибуту name=" URI на шаблон" |
| xsl:choose xsl:when xsl:otherwise | осуществление выбора по условию xsl:when expr="вычисление выражения на script ", language="language-name" test= "вычисляемое выражение" |
| xsl:comment | генерирует комментарий в выходной документ |
| xsl:copy xsl:copy-of | копирует текущей узел в выходной источник или вставляет фрагмент документа в узел, где аттрибут select="имя узла источника" |
| xsl:element | создает выходной элемент по имени, аттрибут name="имя элемента", namespace="uri сслылка на пространство имен" |
| xsl:for-each | повторно применяет шаблон ко всем узлам списка узлов, аттрибут select задает список узлов |
| xsl:if | проверка условия, задается аттрибутом test в виде выражения |
| xsl:include | включает внешний шаблон, аттрибут href = "URI reference" |
| xsl:output | специфицирует выходной результат, аттрибут method может иметь значения "xml", "html" или "text" |
| xsl:param | специфицирует значение параметров, аттрибут name="имя параметра", select = "значание" |
| xsl:processing-instruction | создает инструкцию обработки, аттрибут name="имя процесс инструкции" |
| xsl:sort | сортирует множество узлов, аттрибуты select = "имя узла", data-type = тип данных {"text" | "number" | Qname}, order = направление сортировки {"ascending" | "descending"} |
| xsl:stylesheet | определяет документ xsl-шаблонов, является корневым элементом для XSLT |
| xsl:template | определяет xsl-шаблон, аттрибут name= " URI преффикс на имя шиблона", match= "указание на узел, к которому применяется шаблон" |
| xsl:text | генерирует текст в выходной поток, аттрибут disable-output-escaping = "yes" или "no", указывает на возможность генерации символов ESC |
| xsl:value-of | вставляет значение выбранного узла как текст, аттрибут select= "указатель на узел" из которого берут значение |
| xsl:variable | специфицирует значение границ переменных, аттрибут name = "имя переменной", select = "вычисление значения переменной" |
| xsl:with-param | применяет параметр к шаблону, аттрибут name ="имя параметра", select = выражение для вычисления текущего контекста, значениие по умолчанию "." |
Подробное рассмотрение упомянутых функций API выходит за рамки этой статьи, поэтому интересующихся отсылаю к справке Delphi по Win32 (она, по моему скромному мнению, организована лучше, чем MSDN), а также к книге Джеффри Рихтера "Windows для профессионалов".
Менеджер объектов
В задачу менеджера входит организация взаимодействия между визуальным компонентом инспектора и инспектируемым объектом. Может возникнуть вопрос, для чего нужен посредник? Для ответа на этот вопрос можно выделить несколько моментов:| TGsvObjectInspectorObjectInfo = class public constructor Create; destructor Destroy; override; function ObjectName: String; virtual; function ObjectTypeName: String; virtual; function ObjectHelp: Integer; virtual; function ObjectHint: String; virtual; function PropertyInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; procedure FillList(Info: PGsvObjectInspectorPropertyInfo; List: TStrings); virtual; procedure ShowDialog(Inspector: TComponent; Info: PGsvObjectInspectorPropertyInfo; const EditRect: TRect); virtual; function GetStringValue(Info: PGsvObjectInspectorPropertyInfo): String; virtual; procedure SetStringValue(Info: PGsvObjectInspectorPropertyInfo; const Value: String); virtual; function GetIntegerValue(Info: PGsvObjectInspectorPropertyInfo): LongInt; virtual; procedure SetIntegerValue(Info: PGsvObjectInspectorPropertyInfo; const Value: LongInt); virtual; property TheObject: TObject read GetObject write SetObject; end; |
| type TGsvObjectInspectorListItem = record Name: String; // имя элемента списка Data: LongInt; // значение элемента списка end; PGsvObjectInspectorListItem = ^TGsvObjectInspectorListItem; TGsvObjectInspectorTypeListInfo = class(TGsvObjectInspectorTypeInfo) protected class function ListEnumItems(Index: Integer): PGsvObjectInspectorListItem; virtual; public class procedure FillList(AObject: TObject; List: TStrings); override; class function IntegerToString(const Value: LongInt): String; override; class function StringToInteger(const Value: String): LongInt; override; end; class function TGsvObjectInspectorTypeListInfo.ListEnumItems( Index: Integer): PGsvObjectInspectorListItem; begin Result := nil; end; class procedure TGsvObjectInspectorTypeListInfo.FillList(AObject: TObject; List: TStrings); var i: Integer; p: PGsvObjectInspectorListItem; begin i := 0; p := ListEnumItems(0); while Assigned(p) do begin List.AddObject(p^.Name, TObject(p^.Data)); Inc(i); p := ListEnumItems(i); end; end; class function TGsvObjectInspectorTypeListInfo.IntegerToString( const Value: Integer): String; var i: Integer; p: PGsvObjectInspectorListItem; begin Result := ''; i := 0; p := ListEnumItems(0); while Assigned(p) do begin if p^.Data = Value then begin Result := p^.Name; Break; end; Inc(i); p := ListEnumItems(i); end; end; class function TGsvObjectInspectorTypeListInfo.StringToInteger( const Value: String): LongInt; var i: Integer; p: PGsvObjectInspectorListItem; begin Result := 0; i := 0; p := ListEnumItems(0); while Assigned(p) do begin if p^.Name = Value then begin Result := p^.Data; Break; end; Inc(i); p := ListEnumItems(i); end; end; |
| type TGsvObjectInspectorTypeFontInfo = class(TGsvObjectInspectorTypeInfo) public class procedure ShowDialog(Inspector: TComponent; Info: PGsvObjectInspectorPropertyInfo; const EditRect: TRect); override; class function ObjectToString(const Value: TObject): String; override; end; class procedure TGsvObjectInspectorTypeFontInfo.ShowDialog( Inspector: TComponent; Info: PGsvObjectInspectorPropertyInfo; const EditRect: TRect); var dlg: TFontDialog; fnt: TFont; begin if not Assigned(Info) then Exit; if not Assigned(Info^.NestedObject) then Exit; if not (Info^.NestedObject is TFont) then Exit; fnt := TFont(Info^.NestedObject); dlg := TFontDialog.Create(Inspector); try dlg.Font.Assign(fnt); if dlg.Execute then fnt.Assign(dlg.Font); finally dlg.Free; end; end; class function TGsvObjectInspectorTypeFontInfo.ObjectToString( const Value: TObject): String; begin if Assigned(Value) then if Value is TFont then with TFont(Value) do Result := Format('%s, %d', [Name, Size]); end; |
| TGsvObjectInspectorTypeInfo = class public class function ObjectName(AObject: TObject): String; virtual; class function TypeName: String; virtual; class function TypeInfo: PGsvObjectInspectorPropertyInfo; virtual; class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; virtual; class procedure FillList(AObject: TObject; List: TStrings); virtual; class procedure ShowDialog(Inspector: TComponent; Info: PGsvObjectInspectorPropertyInfo; const EditRect: TRect); virtual; class function IntegerToString(const Value: LongInt): String; virtual; class function StringToInteger(const Value: String): LongInt; virtual; class function CharToString(const Value: Char): String; virtual; class function StringToChar(const Value: String): Char; virtual; class function FloatToString(const Value: Extended): String; virtual; class function StringToFloat(const Value: String): Extended; virtual; class function ObjectToString(const Value: TObject): String; virtual; end; |
Не вдаваясь пока в подробности, опишем, в целом, назначение методов класса.
| TGsvObjectInspectorPropertyInfo = record Name: String; Caption: String; Kind: TGsvObjectInspectorPropertyKind; Tag: LongInt; NestedType: String; NestedClass: TGsvObjectInspectorTypeInfoClass; Help: Integer; Hint: String; end; PGsvObjectInspectorTypeInfo = ^TGsvObjectInspectorTypeInfo; |
| type TLabel_INFO = class(TGsvObjectInspectorTypeInfo) public class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; override; end; class function TLabel_INFO.ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; const DSK: array[0..3] of TGsvObjectInspectorPropertyInfo = ( ( Name: 'Caption'; Caption: 'Надпись'; Kind: pkImmediateText ), ( NestedClass: TGsvBounds_INFO ), ( Name: 'Font'; NestedType: 'TFont' ), ( Name: 'Color'; Caption: 'Цвет фона'; NestedType: 'TGsvColorRGB' ) ); begin if Index |
| initialization GsvRegisterTypeInfo(TLabel_INFO); |
| type TGsvBounds_INFO = class(TGsvObjectInspectorTypeInfo) public class function TypeInfo: PGsvObjectInspectorPropertyInfo; override; class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; override; end; class function TGsvBounds_INFO.TypeInfo: PGsvObjectInspectorPropertyInfo; const DSK: TGsvObjectInspectorPropertyInfo = ( Caption: 'Положение и размер'; Kind: pkFolder; Help: 1234; Hint: 'Координаты верхнего левого угла и размеры' ); begin Result := @DSK; end; class function TGsvBounds_INFO.ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; const DSK: array[0..3] of TGsvObjectInspectorPropertyInfo = ( ( Name: 'Left'; Caption: 'Левый край'; Kind: pkText ), ( Name: 'Top'; Caption: 'Верхний край'; Kind: pkText ), ( Name: 'Width'; Caption: 'Ширина'; Kind: pkText ), ( Name: 'Height'; Caption: 'Высота'; Kind: pkText ) ); begin if Index |
| type TFont_INFO = class(TGsvObjectInspectorTypeFontInfo) public class function TypeInfo: PGsvObjectInspectorPropertyInfo; override; class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; override; end; class function TFont_INFO.TypeInfo: PGsvObjectInspectorPropertyInfo; const DSK: TGsvObjectInspectorPropertyInfo = ( Caption: 'Шрифт'; Kind: pkDialog ); begin Result := @DSK; end; class function TFont_INFO.ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; const DSK: array[0..3] of TGsvObjectInspectorPropertyInfo = ( ( Name: 'Name'; Caption: 'Имя'; Kind: pkText; Hint: 'Имя шрифта' ), ( Name: 'Size'; Caption: 'Размер'; Kind: pkText; Hint: 'Размер в пунктах' ), ( Name: 'Style'; Caption: 'Стиль'; Kind: pkSet; NestedClass: TFontStyles_INFO ), ( Name: 'Color'; Caption: 'Цвет'; Kind: pkColor; NestedClass: TGsvColor16_INFO ) ); begin if Index |
| type TGsvColor16_INFO = class(TGsvObjectInspectorTypeListInfo) protected class function ListEnumItems(Index: Integer): PGsvObjectInspectorListItem; override; public class function TypeInfo: PGsvObjectInspectorPropertyInfo; override; end; TFontStyles_INFO = class(TGsvObjectInspectorTypeSetInfo) public class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; override; end; class function TGsvColor16_INFO.ListEnumItems(Index: Integer): PGsvObjectInspectorListItem; const DSK: array[0..15] of TGsvObjectInspectorListItem = ( ( Name: 'Черный'; Data: clBlack ), ( Name: 'Коричневый'; Data: clMaroon ), ( Name: 'Темнозеленый'; Data: clGreen ), ...... ( Name: 'Розовый'; Data: clFuchsia ), ( Name: 'Голубой'; Data: clAqua ), ( Name: 'Белый'; Data: clWhite ) ); begin if Index 'Цвет'; Kind: pkDropDownList ); begin Result := @DSK; end; class function TFontStyles_INFO.ChildrenInfo( Index: Integer): PGsvObjectInspectorPropertyInfo; const DSK: array[0..2] of TGsvObjectInspectorPropertyInfo = ( ( Name: 'Style'; Caption: 'Полужирный'; Kind: pkBoolean; Tag: Ord(fsBold) ), ( Name: 'Style'; Caption: 'Курсив'; Kind: pkBoolean; Tag: Ord(fsItalic) ), ( Name: 'Style'; Caption: 'Подчеркнутый'; Kind: pkBoolean; Tag: Ord(fsUnderline) ) ); begin if Index |
| procedure GsvRegisterTypeInfo(AClass: TGsvObjectInspectorTypeInfoClass); procedure GsvRegisterTypesInfo(AClasses: array of TGsvObjectInspectorTypeInfoClass); function GsvFindTypeInfo(const ATypeName: String): TGsvObjectInspectorTypeInfoClass; |
| TGsvObjectInspectorTypeInfoClass = class of TGsvObjectInspectorTypeInfo; |
| GsvRegisterTypesInfo([TLabel_INFO, TFont_INFO, TButton_INFO)]; |
| var GsvTypesInfo: TStringList; procedure GsvRegisterTypeInfo(AClass: TGsvObjectInspectorTypeInfoClass); begin if not Assigned(GsvTypesInfo) then begin GsvTypesInfo := TStringList.Create; GsvTypesInfo.Duplicates := dupIgnore; GsvTypesInfo.Sorted := True; end; GsvTypesInfo.AddObject(AClass.ClassName, TObject(AClass)); end; procedure GsvRegisterTypesInfo(aClasses: array of TGsvObjectInspectorTypeInfoClass); var i: Integer; begin for i := Low(AClasses) to High(AClasses) do GsvRegisterTypeInfo(AClasses[i]); end; function GsvFindTypeInfo(const ATypeName: String): TGsvObjectInspectorTypeInfoClass; var i: Integer; begin Result := nil; if Assigned(GsvTypesInfo) then if GsvTypesInfo.Find(ATypeName + '_INFO', i) then Result := TGsvObjectInspectorTypeInfoClass(GsvTypesInfo.Objects[i]); end; |
| Hello, MiniProg 1 |
| Раздел Подземелье Магов |
Я не знаю, к какой области "Королевства" отнести эту статью. В принципе, данная публикация подготавливалась для раздела "Hello, World".
Однако оказалось, что подавляющее количество достаточно опытных программистов, имеют лишь приблизительное понятие об изложенном материале. Почти полное отсутствие в интернете и литературе информации, по данной тематике и использованным в статье методам, оставляют надежду на то, что кому-то, возможно, будет интересно, а может быть и познавательно то, о чем здесь написано.
Первоначальная идея была проста, написать несложную программу, исходный текст которой можно было бы использовать как некий шаблон, с реализованной функциональностью, отвечающей наиболее часто выдвигаемым требованиям. Следует помнить о данной публикации то, что она навеяна темой форума "Delphi Kingdom VCL :)".
Желающие могут присоединиться: покритиковать, дополнить, исправить; и если изменения или найденные ошибки будут существенны, то будет написана новая статья.
Начнем, с требований, которым должна соответствовать программа:
1. Избегать использования компонентов сторонних производителей, стараться написать программу с помощью стандартных, для текущей версии Delphi, функций и процедур.
2. Исходный текст программы необходимо снабдить системой автоматической проверки корректности программного кода.
3. Интерфейс - SDI (MDI хорош для приложений вроде Word или Exceel).
4. Желательно предусмотреть возможность масштабирования размеров окон, а также размеров и положения всех визуальных элементов, расположенных на ней, после изменения размеров экранного шрифта. Размеры окон и визуальных компонентов не должны меняться при изменении разрешения экрана.
5. Программа должна следить за тем, что бы она была запущена в единственном числе, на данном компьютере, при этом при запуске второй копии должна активизироваться первая копия, даже если она находится в свернутом состоянии. Данная функция призвана защитить лишь от случайных или ошибочных действий пользователя, и ни как не претендует на роль "серьезной" защиты.
6. Программа должна иметь возможность запуска с командной строки, с использованием управляющих ключей.
7. Программа должна иметь возможность запуска, как в режиме консоли, так и в режиме с графическим интерфейсом.
8. Программа должна уметь показывать при запуске заставку, и иметь возможность, как изменения времени показа, так и полного отключения заставки. Данные режимы должны быть управляемы как с помощью командной строки, так и в режиме графического интерфейса.
9. Управляющие ключи командной строки, должны поддерживать, как минимум ключ "?" и/или "help"- вывод краткого пояснения о программе, и подсказки о доступных ключах, в режиме консоли. Ключ "concole" - запуск в режиме консоли. Ключ "nologo" - отключение показа заставки. Ключ "logo " c параметром, определяющим время показа заставки.
10. Необходимо предусмотреть возможность взаимодействия программы с конфигурационным файлом, для хранения и восстановления определенных параметров. Нужно уметь хранить в конфигурационном файле время показа заставки, а так же состояние и позицию окон.
11. Необходимо иметь возможность, в режиме с графическим интерфейсом, подключения к программе языковых настроек в виде перевода на различные языки надписей и сообщений. Основной язык программы английский.
Пункт 7 и все, что с ним связано, можно считать моим личным капризом, но мне приходится писать именно такие программы - исполняющиеся в обоих режимах. Для начала, реализации таких требований, должно хватить при создании приложений.
Ну что же, первый шаг, создание директории проекта, назовем его MiniProg, в которой расположим поддиректории:
| DCU - откомпилированные dcu (такова моя привычка :), DOC - поместим текст данной статьи, DUNIT - система автоматического тестирования от SourceForge, IMAGE - для картинок и иконок, SOURCE - исходные тексты самой программы, TEST - исходные тексты тестирующих файлов. |
Будем считать, что основная директория, MiniProg, предназначена для размещения в ней откомпилированной программы, файлов конфигурации и языковых настроек, а так же, для откомпилированной тестовой программы.
Создаем проект, главную форму называем просто и незатейливо - FMain. Cохраняем как файл Main.pas в поддиректории SOURCE. Проект сохраняем как MiniProg.dpr, там же :). Открываем меню Project | Options, переходим на страницу Directories/Conditionals, заносим в Output directory и в Unit output directory соответствующие пути. В нашем случай это будут "..\..\MiniProg" и "..\..\MiniProg\DCU". Можно и короче записать, но так нагляднее. Если есть иконка для программы, то устанавливаем её на странице Application, через Load Icon. Создадим новый unit, сохраним под именем Appl.pas. Зачем? Как задел на будущее, будем размещать в нем функции и процедуры, реализующие наши требования.
Теперь начнем выполнять пункт 2 наших требований, т.е. создавать тестирующую программу. В подкаталоге DUNIT расположены некоторые необходимые нам файлы, взятые из оригинального DUNIT , версии от 2002/01/17. И так, создаем новый проект, закрываем Unit1.pas, отказываемся от сохранения, проект назовем, без особой фантазии, testMiniProg.dpr и сохраняем в TEST. Удаляем всё из этого файла и помещаем в него такой код:
| program testMiniProg; uses Forms, TestFrameWork, GUITestRunner; {$R *.res} begin Application.Initialize; GUITestRunner.RunRegisteredTests; end. |
В настройках проекта, на странице Directories/Conditionals, заполняем поля Output directory и Unit output directory, так же, как и у проекта MiniProg. Дополнительно пропишем в Search path поддиректорий SOURCE и DUNIT. Вот теперь, можно создать новый unit с названием (как бы вы думали?) testAppl.pas и следующим содержанием:
| unit testAppl; interface uses TestFramework, SysUtils, Controls, Forms, Appl; type TTestUnitAppl = class(TTestCase) published end; implementation initialization TestFramework.RegisterTest(TTestUnitAppl.Suite); end. |
Можно откомпилировать testMiniProg и посмотреть на внешний вид нашей тестирующей программы. В дереве просмотра, с именем Test Hierarchy, будут заноситься наши тесты, серые квадратики, при успешном прохождении теста, будут окрашиваться зеленым цветов, иначе - красным или розовым (цвет может быть и синим). Тесты можно отключать галочками. В окнах, расположенных ниже, можно будет наблюдать сообщение о всякой всячине, в том числе и некоторое пояснение о крахе теста. Да, кстати, тесты запускаются кнопочкой, с изображением зеленого треугольника, но пока он окрашен в серый цвет, так как ни одного реального теста у нас нет. Вот, вкратце и всё, что пока нужно знать о DUNIT. Товарищи, желающие узнать о DUNIT больше, а так же патологические "ХочуВсёЗнайки", могут самостоятельно поискать дополнительную информацию. Хочу только заметить, что данная система проверки является портом с JUNIT, и создавалась для применения в проектах с использованием Xtreem Programming (сокращенно XP). Одной из отличительных особенностей данной методологии является глубокая неприязнь к ведению документации :). Подробнее и по-русски можно посмотреть здесь , там же приведены ссылки по этой тематике. Конечно же, возможности DUNIT гораздо шире, чем это будет показано в данном материале (перед самым окончанием статьи была найдена интересная ссылка - по ней можно ознакомиться с более изощренным применением DUNIT).
Попытаемся разобраться с проблемой масштабирования форм. Проведя то, что обычно называется предварительным расследованием; покопавшись в интернет, заглянув в хелп, почитав книги, спросив товарищей (нужное подчеркнуть); выяснилось что, можно принудить форму автоматически масштабировать собственные размеры, а так же размеры и положение размещенных на ней визуальных компонентов, при изменении размера экранного шрифта. Для этого необходимо проверить и если нужно установить свойства формы, в нашем случае FMain, ParentFont = False, Scaled = True, AutoScroll = False и PixelsPerInch равный PixelsPerInch текущего экрана. Данное утверждение верно для форм созданных с помощью Delphi 6.2, для более ранних версий не проверялось. Но, судя по количеству воплей на различных форумах - у некоторых такая проблема была. Впрочем, помнится, еще у М. Канту в "Delphi 2 for Windows95/NT" существовала небольшая глава, освещающая именно такой подход. После рассмотрения исходных кодов VCL Delphi выяснилось, что существует другая проблема, связанная с масштабированием. Дело в том, что свойства Constraints компонентов, к большому сожалению, не масштабируются. Придется заняться этим отдельно, иначе может нарушиться внешний вид формы.
Что делает программа, когда создает форму? Если у формы установлены свойства как было указано выше, то в зависимости от того, отличается PixelsPerInch (сокращенно PPI) формы от PPI экрана или нет, происходит умножение значений местоположения компонентов на "новый" PPI и деление на "старый" PPI (в действительности, конечно, всё сложнее, но на первых порах и такого понимания достаточно). Будем называть эту функцию ScaleValue.
Откроем проект testMiniProg, и откроем в нем файлы testAppl.pas и Appl.pas из поддиректории SOURCE. Теперь самое странное: в testAppl.pas создаем процедуру проверки TestScaleValue, и объявляем её в published свойствах TTestUnitAppl:
| unit testAppl; interface uses TestFramework, SysUtils, Controls, Forms, Appl; type TTestUnitAppl = class(TTestCase) published procedure TestScaleValue; end; implementation procedure TTestUnitAppl.TestScaleValue; var Test: integer; begin Test := ScaleValue(120,96,120); Check( Test = 96, Format('return wrong %d',[Test])); end; initialization TestFramework.RegisterTest(TTestUnitAppl.Suite); end. |
Главное действие в этом unit, происходит в теле процедуры TestScaleValue, по вызову функции Check, в которой проходит проверки первого параметра, и если он False, то тест считается неудачным. Второй параметр функции Check - сообщение, в котором можно написать, в краткой форме, всё, что вы думаете об отрицательном результате тестирования :). Почему, при заданных значениях входных параметров, в результате должно получиться именно 96? - можно понять в результате несложных математических преобразований исходной формулы. Менее успешные математики могут проверить на калькуляторе :). Что же, мы создали тестирующую процедуру, которая проверит корректность работы нашей функции, при чем сделает это автоматически, стоит лишь запустить тесты. Следует сказать, что проверяться функция будет при каждом запуске тестовой программы, т.е. если вы впоследствии поменяете текст функции, и сделаете это некорректно, то программа тут же сообщит вам об этом. Еще одним положительным свойством такого тестирования, является то, что в саму программу не вносится ни каких посторонних тестирующих и проверяющих функций. Далее, в файле Appl.pas, создаем саму функцию:
| function ScaleValue(Value, NewPPI, OldPPI: integer): integer; begin Result := MulDiv(Value, NewPPI, OldPPI); end; |
Компилируем, запускаем программу, нажимаем на зеленый треугольник - всё зеленое! Замечательно, первый и пока единственный тест пройден. Если кто-то не заметил, то поясню, что сначала была создана тестирующая процедура, проверяющая результат функции, и только потом создавалась сама функция. Несколько необычно, но именно такой порядок рекомендует методология XP. Вообще, если призадуматься, то в этом можно узреть глубокий смысл, который заключен в том, что до создания функции мы ДОЛЖНЫ хорошо себе представлять результат :). Вроде бы тривиальная мысль, но многих ошибок в программах не было бы, если бы кодеры всегда следовали этому правилу. Подход, продемонстрированный выше, просто вынуждает поступать именно так. Другим положительным моментом предварительного создание тестовых функций является то что, в конечном счете, изначально "большие" функции будут разбиты на более мелкие и легко тестируемые, что то же неплохо. Кстати, XP настоятельно рекомендует заниматься рефакторингом, по-простому - переписыванием исходного текста, с целью его улучшения. Правда, в отличие от банального исправления ошибок и внесения уточнений, рефакторить рекомендуется только тогда, когда в этом действительно возникла необходимость. Но вообще, код пишется исключительно в требованиях текущего момента, т.е. даже если вы знаете, что какая то дополнительная функциональность вам обязательно понадобиться в дальнейшем - не прилагайте ни малейшего усилия, для её реализации. На этапе рефакторинга всегда можно вернуться к этому, если конечно понадобиться :).
Очевидно, что нам нужны функции, которые бы возвращали значения PPI как времени создания, так и времени исполнения программы, назовем их RtmPPI и DsgnPPI. Напишем тест. Подумав, решаем, что RtmPPI и DsgnPPI должны быть равны по значениям, если разработка программы и тестирование происходит при одних и тех же режима экрана:
| procedure TTestUnitAppl.TestDsgnVsRtmPPI; begin Check( DsgnPPI = RtmPPI, Format('Design time PixelsPerInch not %d DPI', [RtmPPI])); end; |
По крайней мере, такой тест напомнит вам, что при тестировании значение DsgnPPI должно быть равно PPI вашего экрана. Один совет, связанный с масштабированием форм - старайтесь создавать все свои формы при одном и том же PPI, это убережет вас от неприятных эффектов в дальнейшем, либо вам придется написать специальный тест, который будет проверять значения PPI всех форм, а это часто очень утомительно :). Кстати, этот тест наводит на мысль о том, что не плохо было бы завести функцию, которая бы сообщала, изменилось PPI или нет, и она нам нужна именно сейчас, что бы включить в тест. Сам текст функций выглядит следующим образом:
| function RtmPPI: integer; begin Result := Screen.PixelsPerInch; end; function DsgnPPI: integer; begin Result := 120; end; function IsChangePPI: boolean; begin Result := DsgnPPI <> RtmPPI; end; |
К сожалению, функция DsgnPPI возвращает результат, просто используя константу, которая выставляется в зависимости от конкретного PPI, используемого при дизайне (у меня это 120, у вас может быть и другое значение). Несмотря на то, что в хелп указано TForm.PixelsPerInch как свойство, хранящее значение времени создания, проверка показала, что это не так. Рассмотрение исходных текстов подтвердило факт изменения значения TForm.PixelsPerInch при масштабирование формы, во время исполнения. Так как простого и надежного решения данной проблемы у меня ПОКА нет, то поступим в соответствии с принципами Экстремального Программирования - "Если есть что-то что можно отложить на завтра - отложите это". Прошу прощение, у адептов XP, за столь вольную трактовку принципа.
Пришло время заняться процедурой, которая будет масштабировать Constraints компонентов. Собственно говоря, это свойство наследуется от TControl, по этому, будем обращаться именно к нему. Подумаем, как тестировать изменение Constraints. Первое, что приходит в голову, это создать специальную тестовую форму. Конечно, такой путь несколько сложноват, однако эта форма, скорее всего, пригодиться и в дальнейшем. Выбираем меню File | New | Form, даем название testForm и сохраняем как testUnit в поддиректории TEST, если Delphi предложит сохранить еще и проект, смело откажитесь. Не забудьте установить свойства формы так, как было описано ранее. Добавьте, в uses Appl. Проверьте, в меню Project | Options, новая форма должна располагаться в Available Forms, то есть не должна создаваться автоматически, при запуске приложения. Создайте в Events формы событие OnClose:
| procedure TtestForm.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := caFree; end; |
Это заставит удалиться форму из памяти самостоятельно, после закрытия. Не забудьте, выполнить, для testAppl.pas, дополнение через File | Use Unit: Вот, теперь создадим TestChangeConstraints. Что бы легче было тестировать, и избежать неоднозначности, воспользуемся опытом тестирования ScaleValue и зададим размеры формы кратные 120, например 480, после масштабирования должно получиться 384. Так как, отдельные числа используются в unit более чем один раз, то вынесем их в константы.
| const testOldPPI = 120; testNewPPI = 96; ... procedure TTestUnitAppl.TestChangeConstraints; var OK1, OK2: boolean; Size1, Size2: integer; begin OK1 := False; OK2 := False; Size1 := testOldPPI * 4; Size2 := ScaleValue(Size1, testNewPPI, testOldPPI); testForm := TtestForm.Create(Application); try testForm.Constraints.MaxHeight := Size1; testForm.Constraints.MinHeight := Size1; testForm.Constraints.MaxWidth := 0; testForm.Constraints.MinWidth := Size1; ChangeConstraints(testForm as TControl, testNewPPI, testOldPPI); OK1 := (testForm.Constraints.MaxHeight = Size2) and (testForm.Constraints.MinHeight = Size2) and (testForm.Constraints.MaxWidth = 0) and (testForm.Constraints.MinWidth = Size2); ChangeConstraints(testForm as TControl, testOldPPI, testNewPPI); OK2 := (testForm.Constraints.MaxHeight = Size1) and (testForm.Constraints.MinHeight = Size1) and (testForm.Constraints.MaxWidth = 0) and (testForm.Constraints.MinWidth = Size1); finally testForm.Close; Check(OK1 and OK2, 'failed test'); end; end; |
Как видите, тест весьма незатейливый, проверяет корректность масштабирования, как при уменьшающем, так и при увеличивающем масштабе. А еще этот тест использует уже протестированную функцию, что в конечном счете добавляет уверенности в результаты теста :). Сама функция ChangeConstraints выглядит так:
| procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer); begin with Control.Constraints do begin if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI); if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI); if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI); if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI); end; end; |
Запускаем тест - "Шеф!!! Всё пропало!!!" - в чем же дело? А дело в том, что Constraints для минимальных и максимальных значений взаимозависимы. Максимальное значение не может быть меньше минимального и наоборот, и если происходит присвоение некорректного, с этой точки зрения значения, то оно изменяется в нужную сторону. Такое поведение весьма логично, но нас оно не всегда устраивает, по тому что, нам бы хотелось, что бы такое выравнивание сработало после наших изменений. Кстати, вот вам и первый пойманный баг, и довольно хитрый :). Поспешный поиск дихлофоса от Borland. , среди методов TControl, напоминавших по духу, что-то вроде DisabledAlign ничего не дал. Пришлось воспользоваться простым дедовским антитараканным средством - типа "тапочек":
| procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer); begin with Control.Constraints do begin if NewPPI > OldPPI then begin if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI); if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI); if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI); if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI); end else begin if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI); if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI); if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI); if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI); end; end; end; |
Тест, зеленый цвет, "едем" дальше... Дальше? А дальше, расположим на testForm какие-нибудь визуальные компоненты, ...даааа побольше :). В принципе, TestChangeConstraints показал, что процедура работает успешно, с наследником TForm, но не мешало бы, проверить её и с другими компонентами, хотя бы некоторую их часть (нет у нас такого требования - тестировать VCL). Так как предполагаемый процесс тестирования вполне однообразен, то создадим функцию, которой будем передавать компонент, из числа тех, которые расположены на форме, а возвращать она будет - "да" или "нет".
| function TTestUnitAppl.TestScaleControl(Control: TControl): boolean; var OK1, OK2: boolean; Size1, Size2: integer; begin OK1 := False; OK2 := False; Size1 := testOldPPI; Size2 := ScaleValue(Size1, testNewPPI, testOldPPI); testForm := TtestForm.Create(Application); try Control.Constraints.MaxHeight := Size1; Control.Constraints.MinHeight := 0; Control.Constraints.MaxWidth := Size1; Control.Constraints.MinWidth := Size1; ChangeConstraints(Control, testNewPPI, testOldPPI); OK1 := (Control.Constraints.MaxHeight = Size2) and (Control.Constraints.MinHeight = 0) and (Control.Constraints.MaxWidth = Size2) and (Control.Constraints.MinWidth = Size2); ChangeConstraints(Control, testOldPPI, testNewPPI); OK2 := (Control.Constraints.MaxHeight = Size1) and (Control.Constraints.MinHeight = 0) and (Control.Constraints.MaxWidth = Size1) and (Control.Constraints.MinWidth = Size1); finally testForm.Close; Result := OK1 and OK2; end; end; |
Тестовая функция, например, для Label1, будет выглядеть так:
| procedure TTestUnitAppl.TestScaleLabel; begin Check(TestScaleControl(testForm.Label1 as TControl), 'failed test '); end; |
Если все тесты проходят успешно, то с определенной долей вероятности можно утверждать, что мы теперь знаем, как настроить форму так, что бы она автоматически масштабировались, по крайней мере в пределах, которые обеспечивает Delphi. Так же сможем масштабировать Constraints отдельно взятого контрола окна, при необходимости. Думаю, сфера использования ChangeConstraints довольно ограниченна, но в большинстве случаев результаты, полученные с помощью таких простых средств - вполне удовлетворительные. Можно было бы разработать функцию, которая бы сама изменяла Constraints у всех элементов формы. Желающие могут попробовать свои силы самостоятельно, не забудьте только прислать пример с тестом, и он будет включен в проект. По моему скромному мнению, решить эту проблему кардинально и качественно, можно лишь на уровне изменения исходного кода VCL. Хотя, "неумение" Constraints корректировать свои значения во время масштабирование окна и не является "официальным" багом но, очень хочется надеяться, что а можно создать собственный вариант формы, в котором проблема будет решена, но для данного проекта это будет расцениваться как выход за рамки требований (см. пункт.1). Впрочем, повторюсь, если у кого-то есть возможность исправить - пишите.
И так, мы провели некоторые технологические тесты, и убедились в работоспособности функций и процедур основной программы. Пришло время заняться функциональными тестами, то есть тестами, в которых проводится общая проверка на соответствие наших решений требованиям. Наиболее наблюдательные читатели должны были заметить, что к самой программе мы еще и не прикасались, но уже имеем для неё несколько работоспособных функций :). Проводить функциональное тестирование можно по-разному, и в принципе, лучше всего на рабочем приложении. У нас, его пока нет, кроме того, оценить правильность масштабирования можно на любом примере, ведь от нас не требуется реакция (нажатие кнопки, движение мыши и т.д.). Нам нужно просто посмотреть. Так что, воспользуемся testForm и разместим на ней 3 компонента TLabel. В свойство Caption каждой занесем такой текст "0123456789". У Label2 установим Constraints равными Width, у Label3 минимальное и максимальное значения отличающееся не менее чем на 50%, у Label4 минимальное и максимальное значения отличающееся на 5%.
| procedure TTestUnitAppl.TestFuncScale; begin if IsChangePPI then begin testForm := TtestForm.Create(Application); try testForm.ShowModal; finally testForm.Close; end; end; Check(True, 'very strange '); end; |
Тест очень прост, создается и визуализируется окно, рассматривается и закрывается. Процедура выполняется при запуске тестовой программы, если установлено иное значение PPI, чем использовалось при создании. И она всегда завершается успешно, что бы не портить общие "показатели" :). Можно откомпилировать тестовую программу, изменить размер шрифта экрана, перезагрузиться, запустить тест. Естественно, наш тест TestDsgnVsRtmPPI не должен пройти. Зато появиться окно testForm, где можно будет видеть результат масштабирования. Скажу прямо, LabeledEdit меня крайне разочаровал, впрочем, я его всегда подозревал и никогда им непользовался. Зато Label'ы вели себя так как им предписано. Закрываем окно, изменяем шрифт экрана, перезагружаемся, запускаем Delphi. Дальнейшие ухищрения в процессе тестирования, уважаемый читатель, может продолжить и самостоятельно.
Продолжение следует ...
| Declaimer aka Отмазка. |
Я надеюсь, что люди, привыкшие читать академические труды, или слушать классические оперы, не станут осуждать простую и незатейливую песнь кочевника. Что делал - о том и пел.
Исходную партитуру и ноты можно взять .
Любые претензии и предложения принимаются в обсуждении. Предложения будут рассмотрены, претензии - проигнорированы.
С особым вниманием будут рассмотрены уточнения списка требований и новые тесты.
Все копирайты, если они известны, указаны. Иначе, автор не известен или копирайт утерян.
Brodia@a
Специально для
Проект создан в Delphi6 (44.3K)
| |
Прошло некоторое время, клавиатура остыла
| Hello, MiniProg 2 |
| Раздел Подземелье Магов |
Прошло некоторое время, клавиатура остыла после тестирования и писательства, можно продолжать.
Попробуем сделать так, что бы программа следила за тем, что бы она была запущена в единственном экземпляре. Пока мы не углубились в обсуждение деталей реализации, хотелось бы объяснить, для чего такое "суровое" требование единственности и неповторимости. Дело в том, что если пользователям удобнее использовать одновременно несколько копий одной и той же программы, то это верный признак того, что изначально был спроектирован неверный интерфейс, скорее всего больше подошел бы MDI. Это первое, второе - считается, что чаще всего запуск второй копии происходит по ошибке, когда приложение свернуто и его просто не видно.
Данная тема уже не раз поднималась на просторах , например, или . Огромное множество материала, на данную тематику, чьей то щедрой рукой, разбросано по интернету. Правда, все методы однотипные и сводятся к тому, что программа, при запуске, проверяет какой-нибудь признак, если он не обнаружен - то запускается, если же присутствует... В этом месте возможны самые различные реакции, от сообщений, с требованием ответа/нажатия кнопки, до коварнейших систем оповещения создателей (например, как у M$ XP :). Признаком может служить, либо проверка наличия определенного окна, либо отметка в конфигурационном файле/регистре, либо банальный файл, создаваемый при запуске приложения и удаляемый при выходе из него. Более сложные системы, профессионального уровня, обращаются за советом, "можно, или нельзя", к специализированным лицензионным серверам.
Мы пойдем другим путем, наверное, самым простым, будем проверять наличие определенного мьютекса, реакция же будет вежливая - просто активизация окна. Данный метод не нов. Определенно, он работоспособен, но не мешало бы создать тест, который бы нас убедил, что это так. И это еще одна рекомендация XtremeProgramming - не лениться и стараться тестировать как можно больше. Вообще, если бы программисты знали, как много ошибок может быть, в казалось бы, в надежном и простом коде: Откроем testMiniProg.dpr и в файле testAppl.pas создадим следующую процедуру:
| Const StrFailedTest = 'failure test'; ... procedure TTestUnitAppl.TestFindPrevInstance; var Test1, Test2: boolean; Temp: THandle; begin Temp := Mutex; Test1 := not FindPrevInstance('Test'); Test2 := FindPrevInstance('Test'); StopPrevInstance; Check(Test1 and Test2, strFailedTest); Mutex := Temp; end; |
| Var Mutex: THandle = 0; ... function FindPrevInstance(Name: string): boolean; var Temp: THandle; begin Temp := CreateMutex(nil, False, PChar(Name)); Result := (GetLastError = ERROR_ALREADY_EXISTS); if Result then CloseHandle(Temp) else Mutex := Temp; end; procedure StopPrevInstance; begin if Mutex > 0 then CloseHandle(Mutex); end; |
Теперь посмотрим, как можно будет показать найденную первую копию. Вариантов 'поискать и показать форму', в интернете, огромная масса. Тестовая процедура и сама функция выглядят так:
| Unit testAppl; ... procedure TTestUnitAppl.TestShowPrevInstance; begin Check(ShowPrevInstance('DUnit'), strFailedTest); end; unit Appl; ... function ShowPrevInstance(Name: string): boolean; var PrevInstance: HWND; begin Result := False; PrevInstance := FindWindow('TApplication', PChar(Name)); if PrevInstance <> 0 then begin if IsIconic(PrevInstance) then ShowWindow(PrevInstance, SW_RESTORE); SetForegroundWindow(PrevInstance); Result := True; end; end; |
| program testMiniProg; uses Appl in '..\SOURCE\Appl.pas', Forms, TestFrameWork, GUITestRunner, testAppl in 'testAppl.pas', testUnit in 'testUnit.pas' {testForm}; {$R *.res} begin if FindAndShowPrevInstance('DUnit') then Halt else try Application.Initialize; Application.Title := 'DUnit'; GUITestRunner.RunRegisteredTests; finally StopPrevInstance; end; end. |
| function FindAndShowPrevInstance(Name: string): boolean; begin Result := FindPrevInstance(Name); if Result then ShowPrevInstance(Name); end; |
Как видите, с помощью довольно бесхитростных средств нам удалось избежать атаки клонов собственных программ. Посмотрим, что можно сделать дальше.
Способность сохранять в конфигурационном файле какие-нибудь значения, например, положение и размеры окна, так же была освещена в интернет очень широко. В , есть неплохой компонент, умеющий многое, я сам пользовался им когда-то. По этому не будем изобретать ничего нового, но просто воспользуемся уже известными приемами. Почему именно ini-файл, а не регистр, или не способ хранение свойств компонентов, так как это делает Delphi? Свои плюсы и минусы есть у всех подходов, но для наших целей вполне хватит возможностей ini-файла. Будем считать, что ini-файл располагается в директории вместе с программой и имеет такое же имя, но другое расширение, например "ini" :). Традиционно, свойства окна хранят в отдельной секции ini-файла, с уникальным, для данного приложения именем. Используем для этого имя формы. И так, тесты:
| procedure TTestUnitAppl.TestGetIniFileName; begin Check(ExtractFileName(GetIniFileName) = 'testMiniProg' + cfgFileExt, strFailedTest); end; procedure TTestUnitAppl.TestGetSectionName; begin Check(GetSectionName(Screen.Forms[0]) = 'GUITestRunner', strFailedTest); end; |
| Const cfgFileExt = '.ini'; ... function GetIniFileName: string; begin Result := ChangeFileExt(Application.ExeName, cfgFileExt); end; function GetSectionName(Component: TComponent): string; begin Result := Component.Name; end; |
1) отказа от восстановления параметров окна и установка значений по умолчанию,
2) изменение этих параметров в соответствии с изменением используемого шрифта.
Мне, больше по душе метод 'нумбер 2'. Что нужно сделать? вроде бы совсем не многое - всегда хранить размеры окна приведенными в соответствие с PPI времени создания, и при восстановлении проводить коррекцию, в соответствии с PPI времени выполнения. Положение левого верхнего угла формы изменять не следует, этого не делает Delphi, не будем делать и мы. В первой части статьи, говорилось, что величина масштабирования размеров окна зависит от отношения PPI's времен создания и выполнения, и такого понимания, тогда, было достаточно. Настало время все уточнить. На самом деле все обстоит несколько сложнее. Отношение PPI's используется для масштабирования высоты шрифта, после этого вычисляется высота образцового текста (у Delphi это строка '0' :). Ну а далее, для масштабирования, используется отношение старой и новой высот текста. Это отношение будет равно отношению PPI's в случае использования стандартных, для Windows, установок 'Крупный/Мелкий шрифт'. Размеры обычных экранных шрифтов строго фиксированы, по этому, использование нестандартных значений PPI' s может приводить к возникновению неприятных эффектов. В таких случаях, иногда, способен помочь шрифт TTF, например, как предлагается . Следует отметить еще одну особенность масштабирования форм: непосредственно изменяются не сами размеры формы, а размеры клиентской части.
Вооружившись этими знаниями можно придти к выводу, что придется вносить изменения в функцию RtmPPI и DsgnPPI, и вычислять их результат иначе, чем было сделано ранее. Идея проста, использовать для масштабирования высоту текста, времени создания формы и времени выполнения приложения. Судя по всему - это более корректный способ, однако, в названиях переменных и процедур сохранена аббревиатура PPI. Остается вопрос, где, во время исполнения, взять высоту текста времени создания, ведь при создании окна все размеры изменяются. В принципе, все интересующие нас числа хранятся в ресурсах программы и можно попробовать прочитать их оттуда. Но, все попытки обратиться к ресурсам формы в программе, использую стандартные и рекомендованные для этого средства, ни к чему не привели. Точнее, нужные ресурсы программы успешно читаются, но уже в измененном виде, так уж устроен метод TCustomForm.ReadState :(. По этому, попытаемся прочитать данные из ресурса, так же, как это делает Delphi, но в сильно упрощенном варианте. Если вы загляните в исходный код VCL и просмотрите всё, что хоть как-то касается загрузки ресурсов программы, то поймете, зачем эти упрощения. Сведений, в литературе и интернете, связанных с вопросами чтения ресурсов во время исполнения программы, без создания самих компонентов, очень мало. К моему сожалению, практически, я ничего не нашел, и если кто-то знает, где есть подобного рода информация - поделитесь ссылкой. Текст функции, которая читает ресурсы определенной формы, выглядит так:
| unit Appl; ... function ReadFormRes(ResName: string; List: TStringList): boolean; var Prop, Value: string; Stream: TResourceStream; Reader: TReader; HRsrc: THandle; begin List.Clear; HRsrc := FindResource(HInstance, PChar(ResName), RT_RCDATA); Result := HRsrc <> 0; if not Result then Exit; Stream := TResourceStream.Create(HInstance, ResName, RT_RCDATA); Reader := TReader.Create(Stream, 4096); try Reader.ReadSignature; Reader.ReadStr; Reader.ReadStr; while not Reader.EndOfList do begin Prop := Reader.ReadStr; Value := strNil; case Reader.NextValue of vaInt8, vaInt16, vaInt32: Value := IntToStr(Reader.ReadInteger); vaString: Value := Reader.ReadString; else Reader.SkipValue; end; if Value <> strNil then List.Add(Format('%s = %s',[Prop,Value])); end; Reader.CheckValue(vaNull); finally Reader.Free; Stream.Free; end; end; |
Как я уже говорил, здесь представлен упрощенный вариант, который ищет определенный ресурс в программе, и сообщает в результате найден он или нет, а так же заполняет List набором строк найденных свойств и их значений. В список записываются не все свойства, а только те, которые определены в ресурсе и имеют тип, либо целого числа, либо строки, и принадлежат самой форме. При желании, можно организовать рекурсивный обход всех компонентов окна и чтение их свойств. Полный тест для данной функции не приводится, по той простой причине, что он довольно велик и явно выходит за рамки данной статьи. Может быть в другой статье :). Скажу лишь что, при построении такого рода функции, вряд ли стоит эмулировать полностью весь процесс загрузки ресурсов программы. В нашем случае, необходимо прочитать лишь некоторые свойства окна, что мы и сделаем. Конечно, можно поступить и так; создать пустую форму, у которой будет известна высота текста времени создания, но во время выполнения программы нам будет известно её масштабированное значение, что, собственно говоря, и нужно. Но, лично мне такой путь не нравиться, как по стилю решения проблемы, так и по тому, что при таком подходе возможна проблема с Constraints. Тестирующая функция довольно проста, хотя, конечно же, при тестировании полного варианта она выглядит иначе:
| Procedure TtestUnitAppl.TestReadFormRes; var List: TStringList; Test: boolean; begin List := TStringList.Create; try ReadFormRes('TGUITestRunner', List); Test := List.Values['Caption'] = 'DUnit: An Xtreme testing framework'; finally List.Free; Check(Test, strFailedTest); end; end; |
| Unit testAppl; ... procedure TTestUnitAppl.TestFindForm; var Test1, Test2, Test3: boolean; begin Test1 := FindForm('testForm') = nil; testForm := TtestForm.Create(Application); try Test2 := FindForm('testForm') <> nil; finally testForm.Free; Test3 := FindForm('testForm') = nil; end; Check(Test1 and Test2 and Test3, strFailedTest); end; unit Appl; ... function FindForm(FormName: string): TCustomForm; var I: integer; begin Result := nil; for I := 0 to Screen.FormCount - 1 do if Screen.Forms[I].Name = FormName then begin Result := Screen.Forms[I]; Break; end; end; |
В принципе, если бы создатели VCL, придерживались простого правила, присвоения nil указателю, который ссылается на еще не созданный или уже удаленный объект, многое было бы проще, и методологически вернее. И я не вижу ни каких логических объяснений, почему до сих пор это не сделано.
| unit Appl; ... const strDelphiMagicText = '0'; strResTextHeight = 'TextHeight'; ... function RtmPPI(FormName: string): integer; var Form: TCustomForm; begin Result := 0; Form := FindForm(FormName); if Form <> nil then Result := Form.Canvas.TextHeight(strDelphiMagicText); end; function DsgnPPI(FormName: string): integer; var List: TStringList; Form: TCustomForm; begin List := TStringList.Create; try Form := FindForm(FormName); if Form <> nil then begin ReadFormRes(Form.ClassName, List); Result := StrToInt(List.Values[strResTextHeight]); end; finally List.Free; end; end; |
| const testPPI = 16; ... procedure TTestUnitAppl.TestRtmPPI; var Test: boolean; begin testForm := TtestForm.Create(Application); try Test := RtmPPI('testForm') = testForm.Canvas.TextHeight(strDelphiMagicText); finally testForm.Free; Check(Test, strFailedTest); end; end; procedure TTestUnitAppl.TestDsgnPPI; var OldPPI, PPI: integer; begin testForm := TtestForm.Create(Application); try OldPPI := DsgnPPI('testForm'); finally testForm.Free; Check(OldPPI = testPPI, Format('DsgnPPI=%d, not %d', [OldPPI, testPPI])); end; end; procedure TTestUnitAppl.TestDsgnVsRtmPPI; var Test: boolean; Text: string; OldPPI, NewPPI: integer; begin Test := False; Text := strFailedTest; testForm := TtestForm.Create(Application); try OldPPI := RtmPPI('testForm'); NewPPI := DsgnPPI('testForm'); if (OldPPI > 0) and (NewPPI > 0) then begin Test := OldPPI = NewPPI; if not Test then Text := Format('DsgnPPI=%d not equal RtmPPI=%d DPI', [OldPPI, NewPPI]); end; finally testForm.Free; Check(Test, Text); end; end; |
Вроде бы все подготовительные действия выполнены, можно попытаться сохранить/восстановить состояние формы. Текст тестовой функции TestSaveLoadFormState можно посмотреть в testAppl.pas. Логика проверки следующая, создается окно, с некоторой задержкой демонстрируется, запоминается состояние окна в локальной переменной и сохраняется в ini-файле. Устанавливаются другие значения состояния окна, перемещается, сворачивается в левый нижний угол, выжидается некоторое время. Восстанавливается состояние окна, сохраненное в ini-файле. Дополнительно, проводится проверка значений состояния окна, до и после сохранения/восстановления. Если же вас не убедят результаты тестов, то всегда можно будет заглянуть в файл ini и посмотреть всё своими глазами. Сами процедуры сохранения/восстановления, и все процедуры к которым они обращаются, приведены поименно ниже:
| ... procedure WriteIniShowCmd; procedure ReadIniShowCmd; procedure WriteIniFlags; procedure ReadIniFlags; procedure WriteIniWidth; procedure ReadIniWidth; procedure WriteIniHeight; procedure ReadIniHeight; procedure WriteIniLeft; procedure ReadIniLeft; procedure WriteIniTop; procedure ReadIniTop; procedure ScaleFormConstraints; procedure SaveFormState; procedure LoadFormState; ... |
Те, кто смотрел исходники MiniProg1, заметят, что в исходных файлах MiniProg2 проведены некоторые 'косметические' изменения.
Продолжение следует ...
| Declaimer aka Отмазка. |
Исходную партитуру и ноты можно взять здесь: (43K). Предложения будут рассмотрены, претензии - проигнорированы.
С особым вниманием будут рассмотрены уточнения списка требований и новые тесты.
Все копирайты, если они известны, указаны. Иначе, автор не известен или копирайт утерян.
Brodia@a
Специально для
| |
Моделирование данных
Раздел Подземелье МаговЭтот цикл статей посвящен моделированию данных, т.е. некоторым правилам и рецептам, которыми следует (или не следует) руководствоваться, отображая сeмантику предметной области в набор взаимосвязанных таблиц реляционной СУБД. Тексты статей не являются строгим изложением теории и не претендуют на "научность", а являются лишь попыткой поделиться скромным опытом в этой области.
Автор: Сергей Королев.
| Часть I: Определение нормальных форм. |
Процесс нормализации состоит в том, чтобы представить данные в виде набора таблиц, в которых все неключевые поля зависят только от целого - возможно, составного - ключа. Тем самым мы минимизируем избыточность данных, и в каком-то смысле повышаем ее "устойчивость". Известно пять нормальных форм таблиц, однако на практике используются только первые четыре.
Говорят, что таблица соответствует первой нормальной форме, если в каждом поле каждой ее строки содержится ровно одно значение. Ответ на вопрос что такое «ровно одно значение» может дать только постановка задачи и ее анализ. Например, в одной задаче имя, отчество и фамилия человека являются различными значениями, и тогда хранение их в одном поле таблицы нарушает критерий первой нормальной формы. Если разрабатывается система учета кадров, то - поскольку человек может время от времени менять, например, фамилию, - скорее всего, разумно считать имя, отчество и фамилию различными атрибутами. Однако вполне может случиться, что по условиям задачи допустимо считать эти атрибуты одним значением.
Таблица соответствует второй нормальной форме, если она отвечает критерию первой нормальной формы, а значения ее любого неключевого поля зависят от значений всех ключевых полей. Таким образом, если в таблице некоторое поле содержит значение, представляющее собой факт относительно подмножества ключевых полей, то таблица не соответствует второй нормальной форме. Вот пример таблицы, нарушающей вторую нормальную форму:
| Товар (ключ) | Склад (ключ) | Количество | Адрес склада |
| Т001 | Склад 1 | 15 | Вокзальная ул. д.2 |
| Т002 | Склад 2 | 20 | Ленинский тупик д.1 |
| Т003 | Склад 2 | 34 | Ленинский тупик д.1 |
| Т004 | Склад 3 | 22 | Придорожный пер. д.3 |
Значение каждого неключевого поля таблицы в третьей нормальной форме должно представлять собой факт, не зависящий от значений никаких других неключевых полей. Кроме того, таблица должна соответствовать правилу второй нормальной формы. Пример таблицы, не отвечающей критерию третьей нормальной формы:
| Табельный № (ключ) | Имя | Фамилия | Отдел | Название отдела |
| 1001 | Василий | Чапаев | Н-11 | Продажи |
| 1002 | Павел | Морозов | Н-23 | Маркетинг |
| 1003 | Иван | Гадюкин | Н-11 | Продажи |
Например, в базе данных потребовалось хранить информацию о сотрудниках, в том числе о том, на каких музыкальных инструментах он умеет играть, и какие имеет увлечения (хобби). Эти данные можно расположить в одной таблице:
| Сотрудник (ключ) | Муз. инструмент (ключ) | Хобби (ключ) |
| Иванов | Гитара | Горные лыжи |
| Петров | Рояль | Подводное плавание |
| Сидоров | Волынка | Компьютерные игры |
Продолжение следует…
В следующей серии: отдельные рецепты денормализации, автоинкремент.
Сергей Королев,
| Продолжение |
Возможно, эта таблица подойдет для записи всех операций с материалами, но, прежде всего пользователям потребуется отчет об остатках материалов по каждому из имеющихся состояний (в пути, разгружено, оприходовано и пр.) По этой таблице этот отчет строить неудобно: на Inter-base для этого придется написать хранимую процедуру, в которой нужно будет объединить результаты двух запросов, в SQL Server, Oracle, DB2 можно сформулировать всего один запрос для вычисления этих цифр: два запроса объединить конструкцией UNION, а затем с помощью select from select или чего-либо подобного задать окончательные агрегатные вычисления. Этот прием, конечно, сработает, но уже на сотне тысяч записей производительность начнет заметно падать. Вообще, сложные запросы - явный признак неудачной модели данных. В данном случае, нашу таблицу нужно перепроектировать. Каждую операцию перемещения будем кодировать не одной, а двумя записями в таблице: NO - номер операции LN_NO - номер позиции в операции DATE - дата TIME - время MATERIAL - идентификатор материала QUANTITY - количество STATE -состояние
Поле LN_NO будет содержать 0 или 1 и будет частью ключа. В записи для исходного состояния количество запишем с отрицательным знаком (это символизирует тот факт, что материал это состояние покинул), в записи для результирующего состояния знак количества будет положительным.
Кроме того, очевидно, что эта схема позволяет хранить операции, состоящие из более чем двух позиций: например, материал разгружается, некоторая его часть приходуется, а другая часть списывается в брак. Ключевое поле LN_NO будет хранить номер позиции. Итак, получается, что в таблицу нужно записать три записи:
| № опер | № поз | Дата | Время | Mатериал | Кол-во | Состояние |
| 2111 | 1 | 28.02.2000 | 12:28 | Спички | -100 | Принят |
| 2111 | 2 | 28.02.2000 | 12:28 | Спички | 95 | Оприходован |
| 2111 | 3 | 28.02.2000 | 12:28 | Спички | 5 | Брак |
В реальном приложении этот запрос обрастет множеством дополнительных условий и будет связан с другими таблицами, но его основа останется столь же простой и быстрой. А из двух запросов быстрее обрабатывается тот, что проще.
Задача о курсах валют
Вот простая задача - нужно хранить журнал курсов доллара по отношению к рублю. Казалось бы, все просто - создаем таблицу из двух колонок - дата, курс - и методично ее заполняем. После этого обязательно появится сопутствующая задача: есть таблица с суммами в рублях и датой совершения операции. Нужно одним запросом выдать таблицу, в которой все операции пересчитаны в доллары по курсу на дату совершения операции. Вот очевидное неправильное решение: select op.amount * rt.rate, op.reg_date from operations op, rates rt where op.date = rt.date
Почему это неправильно? Во-первых, мы не обязаны хранить курсы валюты на каждый день - это попросту неэффективно, особенно если предполагается хранить данные о движении финансов за несколько лет. Во-вторых, даты совершения операций не обязательно совпадают с датами котировки валюты. Поэтому из результатов этого запроса будут исключены все операции, дата совершения которых трагически не совпала с датой регистрации курса валюты.
Как сформулировать запрос правильно, при условии, что мы не храним курсы за все дни? Для такой модели данных это достаточно нетривиальная задача, достойная помещения в рубрику головоломок Джо Селко . Но лучше бороться не с последствиями, а с причинами - поэтому модель данных следует немного изменить.
В таблицу курсов добавим еще одну дату и будем следить за тем, чтобы эти даты отражали срок действия курса. В качестве начального значения дата окончания срока действия будет достаточно отдаленной, например, 31 декабря 9999 (ну или максимальной из представимых в базе данных). Манипуляции с таблицей курсов слегка усложняются - при вставке очередного курса необходимо согласованно пересчитать срок действия курса, в который попал новый курс. Это легко программируется триггером: create trigger ti_rate for rates before insert as begin update rates set rate_date = new.rate_date-1; where new.rate_date between (rate_date and end_date);
/* если есть курсы с более поздней датой */ select rate_date-1 from rates where new.end_date between (rate_date and end_date) into new.end_date; end
Соответствующим образом следует запрограммировать и триггеры, срабатывающие при модификации и удалении записи.
Теперь можно сформулировать запрос: select op.amount * rt.rate, op.reg_date from operations op, rates rt where op.reg_date between
(rt.rate_date and rt.end_date)
Итак, слегка усложнилась работа при «записи» данных - нам пришлось программировать триггеры; в таблице появилось избыточное поле. Но запрос, с помощью которого вычисляются курсы, остался простым, понятным и главное - быстрым.
Суррогатные ключи и автоинкремент
Если следовать букве правил нормализации, то в таблице следует размещать только атрибуты сущности, отражающие ее свойства, и ничего больше. Однако, на практике это не всегда удобно. У сущности может быть трудно выделить набор атрибутов, обладающих свойством уникальности, либо уникальный атрибут может меняться. Тогда сущность снабжают избыточным атрибутом, не несущим никакой содержательной информации, но неизменным и уникальным, как, например, номер паспорта гражданина или табельный номер работника. Этот атрибут называют суррогатным ключом.
Практически все СУБД содержат те или иные средства генерации уникального суррогатного ключа:
Автоинкрементное поле обладает несомненными достоинствами для программиста: об его уникальности заботится система - значение увеличивается всякий раз, когда в таблицу вставляется запись. В этом, однако, состоит и недостаток автоинкремента: не вставив в таблицу записи, его очередное значение нельзя получить.
Вот иллюстрация. В клиент/серверных приложениях сплошь и рядом встречается задача формирования многопозиционных документов на рабочем месте: счетов, накладных и т.п. Такие документы чаще всего моделируют в базе данных двумя таблицами: первая служит для хранения данных заголовка (даты, общей суммы и пр.), а вторая - для хранения позиций документа. Во второй таблице ко всем ключевым полям первой таблицы добавляется номер позиции. Таким образом, чтобы сформировать запись в таблице позиций документа, необходимо знать ключ записи заголовка, который часто и реализуют с помощью автоинкремента.
То есть алгоритм получается примерно таким:
Однако следует учесть, что один документ формируется достаточно продолжительное время (по крайней мере, минуты). Держать открытой транзакцию все это время неэффективно: на это время в базе данных может быть блокирована не только сама запись, но и страница, или даже таблица целиком.
Тогда может быть, в одной короткой транзакции создать запись заголовка, узнав тем самым новый номер документа, а затем - в следующей транзакции - спокойно формировать список позиций? Это очень плохое решение, так как в этом случае вы не сможете гарантировать семантическую целостность базы данных.
Наилучшим решением представляется использование механизма получения очередных номеров, независимого от таблиц и транзакций, аналогичного, например, генераторам Interbase. Кстати, если СУБД, на которой вы работаете, не имеет такого механизма, но поддерживает вызов внешних функций, то генераторы a la Interbase достаточно просто разработать самостоятельно. Тогда алгоритм формирования документа станет таким:
Преимущества этой схемы достаточно очевидны: транзакция открывается только в момент реальной записи документа (т.е. тогда, когда пользователь нажал кнопку «Сохранить»), время ее работы определяется исключительно объемом данных документа и не зависит от настроения пользователя.
Если вы используете Delphi или C++ Builder, то для реализации подобной схемы подойдут компоненты TClientDataSet и TUpdateSQLProvider.
Сергей Королев
¹ - Здесь и далее используется диалект SQL для СУБД Interbase
² - Joe Celko -SQL-гуру, автор постоянной колонки журнала (бывш. DBMS magazine),
в которой часто публикуются интересные задачи для знатоков SQL.
Модуль для расчета формул II
| Раздел Подземелье Магов |
В этой статье представлена новая версия . Я сделал очень много нововведений, в том числе полностью изменил структуру сценариев. В предыдущем варианте сценарий состоял примерно из равных частей по 4 байта - не рационально, но намного проще. Полное описание структуры новых сценариев приведено в исходном файле модуля. Изменился синтаксис формулы, больше не нужно заключать функции в скобки. Ниже приведены все элементы синтаксиса, многие из них также претерпели изменения:
Прежде всего, улучшен контроль ошибок. Теперь идет строгая проверка последовательности функций с учетом их особенностей. Также доработаны сообщения исключительных ситуаций о найденных ошибках. Изменено зарезервированное слово "bool" на "if", которое служит для обозначения логических выражений. На мой взгляд "if" намного лучше, короче и, как Вы заметили, я стараюсь сделать элементы синтаксиса формулы максимально похожими на те же элементы в Delphi. Изменено свойство "Formula", теперь это свойство "Text". Изменены названия методов для работы с математическим сценарием, например RegisterIntFunction теперь называется RegisterNumFunction. Раньше при регистрации функций важно было следить за их порядком. Поясню на примере. Представьте себе, что Вы регистрируете новую функцию "X". А затем Вы регистрируете еще одну функцию "EXP". В памяти программы они будут находиться именно в порядке регистрации, т.е. сначала "X", затем "EXP". При распознавании формулы в таком же порядке будет происходить поиск функций. Поэтому функция "EXP" никогда не будет распознана, т.к. она включает себя функцию "X", которая будет найдена первой. Сейчас порядок регистрации не имеет значения. Но после регистрации нужно вызвать метод SortNumFunctionsData или SortBoolFunctionsData для соответственно математических и логических функций. Эти методы сортируют зарегистрированные функции таким образом, что первыми оказываются самые "длинные" функции. После регистрации новых типов нужно вызвать метод SortTypesData. Важно помнить, что после сортировки функций, изменятся идентификаторы этих функции в соответствии с их новым положением в памяти. Опять же я приведу пример. Представьте, что Вы регистрируете две новые функции, пусть это будут функции "sin" и "sinh" (такие функции регистрируются автоматически при создании объекта класса TDataEditor, но пример чисто гипотетический): ... type TForm1 = class(TForm) ... private FSinID: Integer; FSinhID: Integer; ... end; ... procedure TForm1.FormCreate(Sender: TObject); begin with DataEditor do begin RegisterNumFunction(FSinID, 'sin', False, True); RegisterNumFunction(FSinhID, 'sinh', False, True); // Допустим, что FSinID = 0, FSinhID = 1; SortNumFunctionsData; // После выполнения этой процедуры, FSinID = 1, FSinhID = 0, // т.е. первой функцией стала наиболее длинная - 'sinh'. end; ... end; ...
Мотивация и постановка задачи
При попытке сформулировать требования к инспектору объектов у меня получился такой список :Набор функций
Здесь приведен текст модуля импорта для использования Timerman.dll.| unit TmImport; interface uses Windows,NotifyDef; const TimerMan = 'TimerMan.dll'; (*** Creating interval timer with object event handler ***) function tmCreateIntervalTimer( hEventProc: TNotifierEvent; // Client event handler Interval : dword; // Time interval, msec Mode : byte; // Timer mode Run : boolean; // Start timer immediately Msg, // Message code (2nd handler parameter) UserParam : dword // User parameter (3rd handler parameter) ) : THandle; external TimerMan name 'tmCreateIntervalTimer'; (*** Creating interval timer ***) function tmCreateIntervalTimerEx( hEventObj : THandle; // Notify object handle Interval : dword; // Time interval, msec Mode : byte; // Timer mode Run : boolean; // Start timer immediately EventType : byte; // Notify object type Msg, // Message code UserParam : dword // User parameter for message ) : THandle; external TimerMan name 'tmCreateIntervalTimerEx'; (*** Closing timer ***) procedure tmCloseTimer(hTimer : THandle); external TimerMan name 'tmCloseTimer'; (*** Starting timer (enable work) ***) procedure tmStartTimer(hTimer : THandle); external TimerMan name 'tmStartTimer'; (*** Stopping timer (disable work) ***) procedure tmStopTimer(hTimer : THandle); external TimerMan name 'tmStopTimer'; (*** Resetting timer ***) procedure tmResetTimer(hTimer : THandle); external TimerMan name 'tmResetTimer'; (*** Set timer mode ***) procedure tmSetTimerMode(hTimer : THandle; Mode : byte); external TimerMan name 'tmSetTimerMode'; (*** Modify timer interval ***) procedure tmSetTimerInterval(hTimer : THandle; Interval : dword); external TimerMan name 'tmSetTimerInterval'; (*** Creating synchronized period timer with object event handler ***) function tmCreateFixedTimer( hEventProc: TNotifierEvent; // Client event handler TimeMask : ShortString;// Time period in CRON format Mode : Byte; // Timer mode Run : Boolean; // Start timer immediately Msg, // Message code UserParam : dword // User parameter for message ) : THandle; external TimerMan name 'tmCreateFixedTimer'; (*** Creating synchronized period timer ***) function tmCreateFixedTimerEx( hEventObj : THandle; // Notify object handle TimeMask : ShortString;// Time period in CRON format Mode : Byte; // Timer mode Run : Boolean; // Start timer immediately EventType : Byte; // Notify object type Msg, // Message code UserParam : dword // User parameter for message ) : THandle; external TimerMan name 'tmCreateFixedTimerEx'; (*** Modify fixed timer CRON mask ***) procedure tmSetTimerMask(hTimer : THandle; TimeMask : shortstring); external TimerMan name 'tmSetTimerMask'; (*** Load fixed timer LastTime ***) procedure tmSetLastTime(hTimer : THandle; var LastTime : TSystemTime); external TimerMan name 'tmSetLastTime'; (*** Save fixed timer LastTime ***) procedure tmGetLastTime(hTimer : THandle; var LastTime : TSystemTime); external TimerMan name 'tmGetLastTime'; implementation end. |
| Раздел Подземелье Магов | н, дата публикации 09 июля 2001г. |
Очень часто в структуре приложения или пакета программ можно выделить функциональные модули, которые обслуживают другие модули. То есть, клиент-серверная архитектура (в широком смысле слова) присутствует в любом мало-мальски сложном проекте. В общем случае сервер выполняет некие действия по заданию клиента. Клиентов, как правило, бывает несколько, и функционирует сервер обособленно (связи с другими модулями минимальны и строго оговорены).
Начало работы с графикой в Delphi
Разделу Подземелье МаговКанва и нестандартные приемы рисования
Антон Григорьев, 23 октября 1999г.
Пример №1 Проект Lines
"Резиновая" линия.
Этот пример показывает, как можно сделать "резиновую" линию - то есть такую, которая тянется за курсором, пока пользователь удерживает кнопку мыши. Такие линии применяются во всех современных графических редакторах. Второе, что делает этот пример - рисует особые линии, которые невозможно нарисовать с помощью стандартных перьев. В этом примере пять типов линий:
Скачать проект: (106 K)
Пример №2 Проект ArcText
Этот пример демонстрирует, как вывести надпись с непрямой базовой линией.
Идея заключается в том, что для каждой буквы рассчитывается свой угол поворота, зависящий от её положения. В данном случае базовая линия представляет собой дугу окружности с заданным радиусом. Начальная точка этой дуги задаётся углом её радиус-вектора с осью Х, конечная определяется длиной надписи. Комментировать в этом примере особенно нечего, достаточно справки по CreateFontIndirect и знания элементарной геометрии.
Скачать проект: (123 K)
Автор: Антон Григорьев, Черноголовка, 1999, специально для Королевства Дельфи
Как уже отмечалось выше, установка непустой области модификации Update Region не заставляет приложение немедленно перерисоваться. Вместо этого, приложение продолжает получать сообщения из очереди, пока все сообщения не будут обработаны. Затем Windows проверяет область модификации, и если область не пустая, посылает сообщение WM_PAINT окну. При проверке области модификации могут быть посланы так же сообщения WM_NCPAINT и WM_ERASEBKGND, если требуется перерисовать рамку ( неклиентскую часть) окна или необходимо очистить окно.
Например, при увеличении размера окна будут посланы все три сообщения : WM_NCPAINT , WM_ERASEBKGND и WM_PAINT. При уменьшении размеров, окну придет только два сообщения из этой группы, сообщение WM_NCPAINT и WM_ERASEBKGND. По смыслу ситуации это резонно - при уменьшении окна клиентская часть его только урезается, следовательно стереть ее надо, а рисовать, вообще говоря, нечего...
Метод UpdateWindow требует немедленной перерисовки клиентской области в обход общей очереди. Предварительно проверяется состояние области модификации: если область модификации не пустая, окну будет послано сообщение WM_PAINT. Если область модификации пуста сообщение WM_PAINT, наоборот, не будет послано.
Если эта область была помечена для стирания, то окну предварительно будет послано сообщение WM_ERASEBKGND.
| Для получения более подробной информации смотрите Help WinAPI по темам: |
Для перерисовки окон в Delphi применяются два метода : TWinControl.RePaint TWinControl.ReFresh Метод RePaint заключается в объявлении всей области окна как некорректной и немедленного запроса на перерисовавание окна. Достаточно привести реализацию этого метода из модуля Controls.pas, чтобы это увидеть: procedure TWinControl.Repaint; begin Invalidate; Update; end; Метод Refresh является модификацией метода RePaint. Для класса TWinControl метод Refresh повторяет вызов RePaint.
Таким образом, если Вам необходимо немедленно обновить окно, воспользуйтесь методом RePaint, если в этом нет необходимости и перерисовку нужно запросить, но в порядке общей очереди, лучше использовать метод Invalidate;
| Для получения более подробной информации смотрите реализацию методов: |
Написание простейшего эксперта
Какой же код нужно написать для создания простейшего эксперта? Для этого нужно написать класс, унаследованный от IOTAWizard (определен в файле ToolsAPI.pas) или одного из его потомков, расположить в модуле процедуру Register, как мы это делали с компонентами, и вызвать внутри ее процедуру RegisterPackageWizard (const Wizard: IOTAWizard);например: RegisterPackageWizard (TMyExpert.Create as IOTAWizard); передав ей в качестве параметра экземпляр заранее созданного эксперта.
Рассмотрим класс IOTAWizard.
| IOTAWizard = interface(IOTANotifier) ['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}'] { Expert UI strings } function GetIDString: string; function GetName: string; function GetState: TWizardState; { Launch the AddIn } procedure Execute; end; |
Интерфейс IOTANotifier нам не понадобится, поэтому давайте рассмотрим методы IOTAWizard: Метод GetIDString должен возвращать уникальный идентификатор эксперта. Например: MyCompany.MyExpert Метод GetName должен возвращать название эксперта Метод GetState должен возвращать [wsEnabled], если эксперт функционирует, wsChecked если выбран. Метод Execute вызывается при запуске эксперта из среды IDE.
Итак, если вы хотите сами программировать действия вашего эксперта, включая добавление в меню IDE и прочее и прочее, унаследуйте его от IOTAWizard.
Если вы хотите, чтобы ваш эксперт отображался в репозитарии Delphi на произвольной странице и по щелчку по его иконке вызывался его метод Execute - унаследуйте его от IOTARepositoryWizard
| IOTARepositoryWizard = interface(IOTAWizard) ['{B75C0CE1-EEA6-11D1-9504-00608CCBF153}'] function GetAuthor: string; function GetComment: string; function GetPage: string; function GetGlyph: Cardinal; end; |
Метод GetAuthor должен возвращать имя от IOTAFormWizard. Он имеет все те же методы и свойства, что и IOTARepositoryWizard, если на странице проектов - от IOTAProjectWizard. Он тоже аналогичен IOTARepositoryWizard.
Если же вы хотите, чтобы пункт меню для вызова метода вашего эксперта Execute помещался в меню Help главного меню IDE, унаследуйте вашего эксперта от IOTAMenuWizard:
| IOTAMenuWizard = interface(IOTAWizard) ['{B75C0CE2-EEA6-11D1-9504-00608CCBF153}'] function GetMenuText: string; end; |
Метод GetMenuText должен возвращать имя пункта меню для отображения, а метод GetState возвращает стиль элемента меню (Enabled, Checked)
Вот так все просто, оказывается!
Некоторые особенности организации данных, требующих больших объемов оперативной памяти.
"Что мы можем описать?
Увы! Это всегда лишь то, что начинает увядать и портиться".
Ницше "По ту сторону добра и зла".
Оглавление.
§1 Постановка задачи.
Статья навеяна многократным изучением книги Д. Кнута "Исскуство программирования для ЭВМ" [1] и личным опытом аммировании алгоритмов, требующих большого объема оперативной памяти. Описанные в [1] методы выделения "наиболее подходящего", "первого подходящего" и "системы близнецов", а также методы освобождения оперативной памяти в настоящее время относятся скорее к операционным системам (ОС) чем к средствам разработки приложений (СРП), что отмечено в конце главы 2.5 II тома [1] самим низации эффективного использования в одной из задач 1 Гбайта оперативной памяти уже в эпоху Windows 95/98/NT/2000. Это обусловило желание высказаться по поводу работы с оперативной памятью в части касающейся СРП. Размер доступной для программы оперативной памяти зависит от разрядности вычислительного устройства, разрядности поддерживаемой ОС и СРП, на которых происходит компиляция или интерпретация алгоритма. Обычно, сначала появляются вычислители с большей разрядностью, затем для них делаются ОС и СРП. В середине 90 г.г. это были 16 и 32-разрядные процессоры, ОС и СРП. Новое тысячилетие, по-видимому, будет эрой 64-разрядных вычислительных средств. Если x0,x1,…,xn-1,xn - адрес идентификатора в программе, где xiО{0,1}, то максимально возможный адрес 2n+1. Для 16-разрядных приложений (n=15) это число составляет 65536, для 32-разрядных приложений 4294967296 (» 4 Гбайта), для 64-разрядных приложений 1,844674407371*10+19. Обычно на эти ограничения в адресации накладываются дополнительные ограничения присущие ОС и СРП. Например, в ОС Windows 95/98/NT/2000 реальный размер максимальной адресации меньше, так как часть доступной оперативной памяти забирает ОС для своих нужд. И ещё СРП позволяют создавать приложения, как правило, с фиксированной разрядностью в смысле адресации. Управление оперативной памятью всегда было актуальной задачей, так как она является одним из дорогостоящих ресурсов предоставляемых вычислительными устройствами. В таблице показана динамика цен оперативной памяти в зависимости от размера для двух фирм в августе 2000 года.
| Название фирмы | Серийный номер (part number) | Объём ОП | Цена в долларах США |
| Kingston Technology | KTH6521/64 | 32 Мбайта | 168 |
| Kingston Technology | KTH6521/64 | 64 Мбайта | 143 |
| Kingston Technology | KTH6521/128 | 128 Мбайта | 269 |
| Kingston Technology | KTH6521/256 | 256 Мбайта | 521 |
| Kingston Technology | KTH6742/512 | 512 Мбайта | 1220 |
| HP | D6522A | 64 Mбайт | 126 |
| HP | D6523A | 128 Mбайт | 239 |
| HP | D6743A | 256 Mбайт | 479 |
| HP | D6742A | 512 Mбайт | 2643 |
Тенденция очевидна, за исключением схемы с номером KTH6521/64, из-за большого спроса на оперативную память в 64 Мбайт. Перед тем как приступить к основному повествованию оговорюсь, что далее речь будет идти о структурах данных состоящих из однотипных элементов. Это линейные списки [1] и массивы.
§2 Работы с большой оперативной памятью при 16-разрядной адресации.
Во времена, когда 640 килобайт (conventional memory или обычная память, или основной памятью) была пределом доступной для программистов оперативной памятью, приходилось бороться за десятки "лишних" килобайт, придумывая драйверы, позволяющие выйти за пределы возможностей 16-разрядных приложений и ограничений ОС. Например, стандарты EMS (expanded memory), которая продавалась на отдельной плате со своим процессором, и XMS (extended memory), которая была организована так же, как и основная. В настоящий момент интерес к таким драйверам снизился в связи с появлением процессоров, ОС и СРП с большей разрядностью, но для иллюстрации идей и методов представляется интересным рассмотреть и этот случай управления оперативной памятью. В ОС DOS (disc operation system) оперативная память распределялась следующим образом:
OpArray = object(AbstractArray) constructor Init(Rows, Cols : Word; ElementSize : Word; FileName : String; HeapToUse : LongInt; ArrayOptions: Byte; var Priority : AutoPriority); .... end; Объект поддерживает размещение данных в памяти с прямой адресацией, размещение данных в "верхней" памяти и временных наборах данных на долговременных носителях. Для унификации методов доступа к данным и обработки ошибок, возможно создание дополнительного объекта.
PAsciizStringArray = ^TAsciizStringArray; TAsciizStringArray = object(TObject) ... constructor Init(Rows, Cols, Element : Word; FileName: String; HeapToUse: LongInt); procedure InsertQ(var Item: Asciiz); ... end; var OA: OpArray; ... constructor TAsciizStringArray.Init(Rows, Cols, Element : Word; FileName: String; HeapToUse: LongInt ); const ArrayOptions : Word = LDeleteFile + LRangeCheck; MyDefaultPriority:AutoPriority=(LXmsArray,LRamArray,LEMSArray, LVirtualArray); {массив может располагаться в ОП с прямой адресацией (LRamArray), в "верхней" ОП (LXMSArray и LEMSArray) и во временных наборах данных (LVirtualArray)} ... var E: Word; begin XmsAvailable := TRUE; OA.Init(Rows, Cols, Element, FileName, HeapToUse, ArrayOptions, MyDefaultPriority); Count := 0; E := OA.ErrorA; if E <> 0 then ErrorM(E, Count); {обработка ошибок} OA.ClearA(ItemDefault, ExactInit); {предварительная очистка массива} E := OA.ErrorA; if E <> 0 then ErrorM(E, Count); {обработка ошибок} ... end; procedure TAsciizStringArray.InsertQ(var Item: Asciiz); var E: Word; begin OA.SetA(count, 0, Item); {метод вставки, наследуемый от AbstractArray } E := OA.ErrorA; if E <> 0 then ErrorM(E, count); Inc(Count); end; ... Для использования объекта надо описать его и запросить ресурс в оперативной памяти.
... PS: PAsciizStringArray; AS: Asciiz; ... PS := New(PAsciizStringArray, Init(MaxSize, 1, SizeOf(S), 'kadr.wrk', MaxAvail div 2 )); ... PS^.InsertQ(AS); {вставка новой строки в динамический массив} ... Попутно отметим, что в объекте TAsciizStringArray могут быть решены также вопросы отсева дубликатов, поиска, сортировки и другие, выходящие за рамки тематики статьи. Также обратите внимание на размер запрашиваемой памяти с прямой адресацией - параметр HeapToUse, который равен половине доступной памяти (через функцию MaxAvail). Это необходимо предусматривать, т.к. возможны явные или неявные запросы на свободную память из других мест Вашей программы или из программ работающих параллельно с Вашей и требующей памяти, для избежания коллизий. Программа, фрагменты текста которой приведены выше, будет работать в DOS или как эмулируемое DOS приложение в последующих ОС Windows фирмы Microsft. В поддиректории "XMS в DOS" можно найти исходные тексты системы "Кадры", при программировании которой использовался вышеописанный механизм хранения данных.
Некоторые принципиальные моменты при создании клиентской части
Как уже пояснялось, при создание XML-документа используется его представление в виде DOM модели. Ниже приведен пример части текста Delphi программы создания заголовка xml сообщения.procedure TThread1.HeaderCreate(Sender: Tobject); var coDoc : CoDomDocument ; // объявление сокласса, необходим для создания Doc : DomDocument ; // объекта XMLDomDocument r : IXMLDOMElement; // объявление объектов DOMElement Node : IXMLDOMElement; // txt : IXMLDOMText; // DOMText attr : IXMLDOMAttribute; // DOMAttribute begin Doc:=coDoc.Create; // создание документа DOM Doc.Set_async(false); // установка синхронного режима обрабработки Doc.LoadXML('
Следует отметить, что объявление переменной coDoc : CoDomDocument и Doc : DomDocument , а также ее создание методом Create ( Doc:=coDoc.Create;) осуществляется один раз. Объявление переменной находится в секции описания глобальных переменных, а не в локальной процедуре, как было продемонстрировано для наглядности в данном примере (т.е. одна глобальная переменная типа DomDocument на один программный модуль).
Результатом работы вышеприведенной программы будет созданный заголовок
 |
 |
| Рис 7. |
Рис 8. |
Для формирования xml-документа, содержащего инвойс первоначально строится SQL-запрос (запрос А) с информацией о самом инвойсе:
SELECT * FROM Invoice_General WHERE InvoiceNum = :num // :num - параметр, который задает номер инвойса.
и далее строится SQL-запрос (запрос В) информация о товарах, описываемых в инвойсе (детальная спецификация):
SELECT Goods,Qulity,Price, HZ_cod FROM Goods WHERE InvoiceNum = :num // :num - параметр, который задает номер инвойса.
Ниже представлена часть программы, формирующей тело xml-документа:
procedure TThread1.DataBodyCreate(Sender: Tobject); var //coDoc : CoDomDocument ; // объявление сокласса и объекта XMLDomDocument //Doc : DomDocument ; // должно быть глобальным, для всего модуля. r : IXMLDOMElement; // объявление объектов DOMElement Node, Node2 : IXMLDOMElement; // DOMElement; Node3, Node4 : IXMLDOMElement; // txt : IXMLDOMText; // DOMText str : String; // InvoiceNumber: integer; - глобальная переменная - имеет значение 987654 // queryA, queryB : String; - глобальная переменная, имеет значение, соответсвующее запросу // queryA - запрос А генеральная информацией об инвойсе // queryB - запрос B информация о товарах, описываемых в инвойсе (см. текст) begin Query.Close; // закрывает запрос для доступа Query.Text := queryA; // см. по тексту "запрос А" Query.Params[0].AsInteger := InvoiceNumber; // присваивание значения параметров Query.ExecSQL; // выполнение запроса Query.Open; // открытие доступа к данным запроса r:=Doc.Get_documentElement; // получение адреса корневого элемента Node2 := Doc.createElement ( ' Request '); // создание DOMElement (таг
В результате выполнения данной процедуры формируется следующий текст XML-документа:
 |
procedure Open(const bstrMethod, - тип метода ="POST" bstrUrl, - Url адрес сервера varAsync, - режим связи асинхронный/синхронный = true bstrUser, - имя пользователя для аутентификации bstrPassword) - пароль
| Раздел Подземелье Магов |
Итак, поставлены две задачи для Interbase:
Зададим три генератора:
генератор автоинкрементного поля для таблицы 1 CREATE GENERATOR j_gen; SET GENERATOR j_gen to 0;
генератор для процентовки CREATE GENERATOR PROC_gen; SET GENERATOR PROC_gen to 0;
генератор, обозначающий код ошибки (по ходу решаем задачу 2) CREATE GENERATOR error_code_gen; SET GENERATOR error_code_gen to 0;
Определим три процедуры
SET TERM ^ ; /* процедура заполнения таблицы 1 */ CREATE PROCEDURE FILL (x INTEGER) RETURNS (error_code INTEGER) /*Возвращающей код ошибки*/ AS declare variable j integer; BEGIN BEGIN /*Сначала обнулим безопасным способом код ошибки*/ error_code=gen_id(error_code_gen, 0); WHILE (error_code<0) DO error_code=gen_id(error_code_gen, 1); j=0; WHILE (j
В архиве приведен подробный пример приложения на Delphi, вызывающего, эти процедуры. Отображается линейка процентовки, которую можно остановить.
Скачать архив (12 K)
Кубанычбек Тажмамат уулу,
30 мая 2001г.
Специально для
Некоторые решения с применением хранимых процедур. ( v.1.02.)
| Раздел Подземелье Магов |
С учетом замечаний читателей изменена нотация в задаче 1.
Язык SQL поначалу кажется очень неповоротливым. Но по мере его освоения приходит мысль о том, что здесь имеем дело с МНОЖЕСТВОМ записей, отвечающих определенным непротиворечивым условиям. Хранимые процедуры - мост между этим МНОЖЕСТВОМ записей и ОТДЕЛЬНОЙ записью, принадлежащей этому множеству. Вот решения некоторых задач с применением хранимых процедур. Применяемый SQL сервер - народный interbase\firebird.
Сырцы взяты из текущих проектов, но, думаю, применяемые решения будут понятны (и полезны).
1. Одновременное отображение физических и юридических лиц, отвечающих дополнительному условию.
Иногда бывает необходимо держать данные о физ лицах и юр лицах в разных таблицах.
Краткое описание таблиц
Владельцы ценных бумаг считаются просто ЛИЦАМИ, а какое это лицо и его ФИО (в случае физ лица) или НАЗВАНИЕ (в случае юр лица) отобразит хранимая процедура. CREATE TABLE PERSON( PERSON_CODE INTEGER NOT NULL PRIMARY KEY ); CREATE TABLE NATUR( NATUR_CODE INTEGER NOT NULL PRIMARY KEY , PERSON_CODE_E INTEGER NOT NULL , FOREIGN KEY (PERSON_CODE_E) REFERENCES PERSON (PERSON_CODE) ON UPDATE CASCADE ON DELETE CASCADE ); CREATE TABLE JURID( JURID_CODE INTEGER NOT NULL PRIMARY KEY , PERSON_CODE_E INTEGER NOT NULL , FOREIGN KEY (PERSON_CODE_E) REFERENCES PERSON (PERSON_CODE) ON UPDATE CASCADE ON DELETE CASCADE ); А вот и текст процедуры. CREATE PROCEDURE SP_ALL_OWNERS ( /*входные аргументы*/ NAME_FRAG VARCHAR(20), /*вызывающий обрамляет его в %%*/ SECUR_CODE INTEGER, BROKER_CODE INTEGER) RETURNS ( /*выходные аргументы*/ NAME VARCHAR(45), PERSON_CODE INTEGER, SECUR_CODE_G INTEGER, OWNER_CODE INTEGER) AS begin /*условия, общие для физ и юр лиц*/ for select SECUR_CODE_G, OWNER_CODE, PERSON_CODE_G from OWNER where OWNER.SECUR_CODE_G=:SECUR_CODE and OWNER.BROKER_CODE=:BROKER_CODE into :SECUR_CODE_G, :OWNER_CODE, :PERSON_CODE do begin /*условия, частные для физ лиц*/ for select FIO from NATUR ,NAT_HIST where NAT_HIST.FIO LIKE :NAME_FRAG and NATUR.PERSON_CODE_E=:PERSON_CODE and /*лицо*/ NATUR.NATUR_CODE=NAT_HIST.NATUR_CODE and NAT_HIST.VALID_NOW=1 into :NAME do suspend; /*условия, частные для юр лиц*/ for select FULL_NAME from JURID ,JUR_HIST where JUR_HIST.FULL_NAME LIKE :NAME_FRAG and JURID.PERSON_CODE_E=:PERSON_CODE_ and /*лицо*/ JURID.JURID_CODE=JUR_HIST.JURID_CODE JUR_HIST.VALID_NOW=1 into :NAME do suspend; end end^ при создании физ и юр лиц :
Для отображения в детали (мастер-деталь) результата, возвращаемого хранимой процедурой, в компоненте TIBQuery, как известно можно создать запрос с параметром.
select * from SP_ALL_OWNERS('%некто%', :SECUR_CODE) order by NAME;') а назначив свойство qryDetail.DataSource=masterDataSource, можно дать понять IBX-у, что значение параметра :OWNER надо искать в текущей записи указанного мастера.
2. Перестройка баз данных из источника, не поддерживающего автоматической целостности ссылочной системы с проверкой уникальности первичных ключей и целостности внешних ключей.
Проверка уникальности первичных ключей
Описание таблиц:
Описание таблиц:
Были рассмотрены и другие решения поставленной задачи, но описанный вариант показал минимальный расход времени.
То же самое наблюдалось при закачивании аналогичной таблицы из формата dbf в interbase с применением препроцессора gpre и низкоуровневым доступом к формату dbf (будет описано в следующей статье).
3. Выборка пакетами записей с фиксированным числом записей.
CREATE PROCEDURE SHOW_PART( SINCE INTEGER, TILL INTEGER) RETURNS ( THE_CODE integer, NAME varchar(10)) AS declare variable i integer; begin i=0; for select THE_CODE, NAME from MY_TABLE where NAME='qq' into :THE_CODE, :NAME do begin i=i+1; if ((SINCETILL) then begin exit; end end ^ при n1>1 приведенное решение немного неоптимально, т.к. серверу приходится перебирать заново все записи, соответствующие поставленному условию.
Верхняя допустимая граница TILL, как известно, определяется простым select count()-ом
Выборку производить следующим образом
select * from SHOW_PART(1,3); - показать с первой по третью записи, удовлетворяющие заданному в процедуре условию.
Кубанычбек Тажмамат уулу,
16 мая 2001г.
Некоторые важные моменты
Выше было сказано, что при больших размерах картинки и при небольшем объеме текстового файла отличить исходную и "слепленную" картинку практически невозможно. Это правильно, но только отчасти. Если взглянуть на изображения, в котором "зашит" большой текстовый файл, то сразу же в глаза бросаются чужеродные пиксели, распределенные по всему изображению (кстати, коэффициент разброса можно менять) а особенно хорошо эти пиксели видны на рисунке, с однородным фоном. Сравните следующие два рисунка:
На правом рисунке отчетливо виден шум. Этого отчасти можно было бы избежать, используя неоднороные рисунки с резкими переходами цвета, а также рисунки большего формата. Или можно написать такой хитрый алгоритм кодирования, что второе изображение будет невозможно отличить от первого. В примере вместо увеличения размера рисунка я просто уменьшил количество информации:
Немного истории
Упоминаемые термины виртуальный таймер, таймерный менеджер имеют для данной разработки историческое происхождение.В начале 90-х годов прошлого века я занимался разработкой контроллеров на i8051 и софта для них (макроассемблер 2500 A.D.). И был тогда сделан "драйвер виртуальных таймеров", расширяющий возможности однокристалки (у нее всего два аппаратных таймера) по обеспечению программы инструментами отсчета времени. Будильников там еще не было. Работа велась в обработчике аппаратного прерывания.
В 1993 году в составе программы верхнего уровня системы учета энергоресурсов в среде DOS (Turbo-Pascal), в разработке которой я участвовал, был таймерный менеджер (тот самый TIMERMAN). Он предоставлял набор интервальных таймеров и ежесуточных будильников, имея обработчики прерываний стандартного таймера ($1C) и будильника RTC ($4A). Интервал в секундах до 65535. Обработка таймеров выполнялась, когда менеджер получал управление в общем цикле программы (была организована кооперативная многозадачность между модулями). Клиент мог сам проверять таймер или передать адрес своей процедуры - натуральный callback. Позднее, с переходом на BP7 и protected mode, менеджер перекочевал в независимую DLL.
В 1997 году Timerman был портирован под OS/2 (Virtual Pascal) без изменений в архитектуре - только прерывание было заменено на Thread.
В 1999 году в связи с разработкой системы учета под Windows CE был разработан заново таймерный менеджер, и был он в виде DLL. Практически это было то, что я сейчас предлагаю, только реализация на VC++ (без использования MFC). В том же году Timerman.dll был переписан на Delphi в современном виде.
Необходимые файлы
Несколько слов о загрузке DLL
Здравствуйте, коллеги! Поводом для написания этой статьи стало прочтение статьи Криса Касперски .
Вкратце содержание статьи (дается в произвольном виде, со своими коментариями).
Все исполняемые модули (EXE и DLL) грузятся в память Windows(NT/2000/XP) следующим образом (я оставил только важные для нас пункты) Загрузка первой копии приложения:
Отличий, вроде бы, никаких? Но (!!!) пункт 2 говорит, что память выделяется всем копиям одна и та же(!!!). Таково свойство проецируемых файлов(см. Help. Topic: CreateFileMapping, OpenFileMapping, MapViewOfFile …).
"А как же данные каждого приложения, которые не зависимы от других приложений?"- спросите Вы. А для этого и стоит защита. Как только программа пытается писать что-то в память, система делает копию этой страницы, ставит ей соответствующую защиту, и далее это приложение работает со своей (измененной) страницей, а все остальные с общей. Зачем так сложно? Из экономии памяти и увеличения быстродействия, ведь когда идет SWAP памяти, не измененные страницы система просто удаляет (ведь они остались в исполняемом файле), а измененные скачиваются в SWAP-файл. Когда данные опять понадобятся, они читаются из разных мест (из исполняемого файла или из SWAP-файла).
В первом случае мы имеем огромный плюс:
Теперь про упаковку файла. После проецирования, прежде чем модуль будет готов, он распаковывается специальной подпрограммой. Т.е. сразу при загрузке модуль переписывает всю (!!!) свою память, что заставляет систему выделить ее (память) в отдельный блок. Т.е. ни о какой экономии речь уже не идет. Ладно, если Вы запустили упакованный таким образом NotePad, а если Word? Да еще и 3 раза?
А теперь, непосредственно по теме данной статьи.
Хорошо. Мы вняли голосу умного человека и не стали паковать файл(ы). И казалось бы, все хорошо. НО Ваш проект устроен так, что он использует кучу DLL, которые Вы сами и написали. И у всех у них базовый адрес стоит $10000000(0х10000000-на CPP). А теперь вернемся к загрузке (точнее к пункту 3), попробуем понять что такое базовый адрес и зачем он нужен.
В любой программе есть инструкции, которые привязаны к адресу. Например: По адресу $1000000 у нас находится переменная "X";
Где-то мы к ней обращаемся.
| ... ; Какой-то код и данные org 1000000h X dword ? ; Переменная Х по адресу $1000000 Y dword ? ; Переменная Y по адресу $1000004 ... ; Какой-то код и данные mov eax,[1000000h] ; Обращаемся к переменной inc eax ; mov [1000000h],eax ; ... ; Какой-то код и данные |
| ... ; Какой-то код и данные org 0FFFFFCh X dword ? ; Переменная Х по адресу $0FFFFFC Y dword ? ; Переменная Y по адресу $1000000 ... ; Какой-то код и данные mov eax,[1000000h] ; Обращаемся к переменной inc eax ; mov [1000000h],eax ; ... ; Какой-то код и данные |
Ну, Вы уже поняли "где собака порылась"? Подсказываю, исправляет код - значит записывает туда другое значение. А теперь понятно? Правильно. Опять вся память модуля летает в SWAP и назад. И системе совершенно все равно, по какой причине произошла запись в код: при распаковке или при исправлении кода. Все равно этот экземпляр уже лежит в памяти "тяжелым грузом".
Причем, как показывает практика, таких DLL(а это относится на 99.9% к ним, т.к. до загрузки EXE в памяти процесса вообще больше ничего нет, и его(EXE) можно грузить куда угодно и по любому адресу), в системе может набираться на мегабайты. У меня например таких DLL набралось на 23М :((((((. Т.е. почти 10% физической памяти(у меня стоит 256M :)))))). Но мне хорошо. Винт быстрый, и 10% это не смертельно. А каково тем, у кого 64М? В конце статьи пример распечатки загруженных DLL для Explorer(Проводника). Жирным выделены модули, загруженные не по базовым адресам. Общая длина модулей ~1.8 метра.:(((((((
Причем самое странное, что не только рядовые программеры не заботятся об этой проблеме (извините, народ, но мы почти все, и я в том числе, относимся к рядовым) но и "бренды" вроде Касперского, Intel, и др. делают то же самое.
Как исправить создавшееся положение? К сожалению, готового решения данной проблемы у меня нет. С Visual Studio идет программа ReBase.exe, которая изменяет базовый адрес указанного модуля. Но это надо сидеть и аккуратно все(!!!) DLL исправлять. А их у меня в системе, более 5 тысяч. Поэтому этот вопрос был, есть, и "будет есть". А эта статья призвана убедить Вас уменьшить обьем хаоса в этом мире. Конечно, разные разработчики вполне могут загнать свои DLL по одному и тому же адресу. Поэтому я, для себя, например, выбрал такую тактику, все свои DLL я гружу, начиная с адреса $20000000, причем ни одна DLL не пересекается с другой, даже из разных проектов. Для этого, правда, приходиться иметь базу данных уже использованных адресов. Как показывает практика и анализ процессов в системе, системные DLL Windows имеют разный базовый адрес. Более того, некоторые из них имеют фиксированный базовый адрес(см. Пример). А также, можно заметить, что с адреса $20000000 и до адреса $30000000 с копейками, пустое пространство. Вот это место я себе и облюбовал :)))).
Вывод. В системе всегда есть "плохие" модули. Но если Вы свои модули будете разносить по разным адресам, то и стандартные модули будут грузиться по базовым адресам, и в конечном итоге Ваша система будет работать быстрее и эфективнее.
Скачать:
Михаил Басов
Несколько слов об организации документооборота.
Общим правилом разработки системы обмена XML документами является:Каждый XML документ, подобно HTML документу, должен состоять из заголовка сообщения (информация заключенная тагами ) и тела сообщения (для запроса эта информация обрамленная тагами для ответа на запрос ). Для того, чтобы XML документ был правильно сформирован, необходимо его две составные части "Заголовок" и "Запрос" обрамить тегами, например
 |  | ||
| Рис 4. | Рис 5. |
Заголовок (Рис 4), в отличие HTML документа, должен содержать разного рода служебную информацию, в том числе информацию о типе передаваемого документа и процессе его обработки. В информационную обработку поступает тело документа, т.е. содержательная часть обрамленная тагами . Следует отметить, что структуру заголовков должна быть единой для всех типов документов.
Для запущенного сервером Процесса, алгоритм обработки предпочтительно (но не обязательно) строить следующим образом:
 |
Об одном подходе к реализации Инспектора объектов
| Раздел Подземелье Магов |
Предварительные замечания
В свою очередь хочу поблагодарить Разинкина Игоря за некоторые , до которых я сам не дошёл ("кукушка хвалит соловья за то, что хвалит он кукушку!"). Во-первых, за хорошую мысль насчёт использования в окне Инспектора объектов компонента TPaintBox (в первых реализациях своего Инспектора я изрядно помучился с TStringGrid'ом). Во-вторых, за идею динамического создания/уничтожения редакторов свойств (я ранее размещал сразу все, что здорово притормаживало работу программы).
Ещё один момент… Все предоставленные исходные файлы Инспектора и примеры реализованы в Delphi 6, так что могут возникнуть проблемы с переносом форм в более ранние версии. Но, так как, начиная, по-моему, с пятой версии, формы в DFM-файлах хранятся в текстовом формате, можно "воссоздать" их заново, то есть читать их свойства в моих DFM и переносить в свои. Учитывая то, что многие работают на более ранних версиях, чем моя, я старался не использовать компоненты, классы или процедуры, специфичные для Delphi 6. Правда, есть в одном примере класс TObjectList (он, по-моему, появился в пятой версии), но его можно реализовать таким образом: interface ... type TObjectList = class(TList) private function GetItem(Index: Integer): TObject; public property Items[Index: Integer]: TObject read GetItem; default; function Add(Item: TObject): Integer; end; ... implementation ... function TObjectList.GetItem(Index: Integer): TObject; begin Result := TObject(inherited Items[Index]); end; function TObjectList.Add(Item: TObject); begin Result := inherited Add(Item); end; ... Остальные свойства и методы TList можно не перекрывать, они в примере не задействуются.
Последний нюанс... Инспектор далёк от совершенства: при изменении его размеров возникает "мелькание", при изменении размера полей иногда поля значений налезают на поля названий, при редактировании пропадает список редактируемых объектов. Могут возникать и непредвиденные ошибки. Всё потому, что я хотел показать лишь идею, а детали - дело техники!
| initialization TComponentFactory.Create(ComServer, Ttest, Class_test, ciMultiInstance, {tmApartment} tmNeutral ); |
| type {$M+} TRect_Proxy = class public constructor Create(ARect: PRect); private FRect: PRect; // указатель на экземпляр записи function GetLeft: Integer; function GetTop: Integer; function GetWidth: Integer; function GetHeight: Integer; procedure SetLeft(const Value: Integer); procedure SetTop(const Value: Integer); procedure SetWidth(const Value: Integer); procedure SetHeight(const Value: Integer); published property Left: Integer read GetLeft write SetLeft; property Top: Integer read GetTop write SetTop; property Width: Integer read GetWidth write SetWidth; property Height: Integer read GetHeight write SetHeight; end; {$M-} constructor TRect_Proxy.Create(ARect: PRect); begin Assert(Assigned(ARect)); FRect := ARect; end; function TRect_Proxy.GetLeft: Integer; begin Result := FRect^.Left; end; ... procedure TRect_Proxy.SetHeight(const Value: Integer); begin FRect^.Bottom := FRect^.Top + Value; end; |
Обзор существующих библиотек.
Первое что я сделал – сходил на torry.ru и был удивлен обилием библиотек и функций для разного рода шифрования. Функциональность их я проверять не стал, а остановился на PGP-пишных компонентах.PGPComp - ДОСовская, работает по принципу запуска внешнего exe-файла, сразу отпала по той причине - что нужно будет устанавливать MSDOS версию PGP (Кроме того библиотека только под 1 и 2 Delphi). Вспомнил что в моей любимой почтовой программе The Bat встроена поддержка PGP, зашел на их сайт - скачал библиотеку dklib.dll, любезно предоставленную ими, но почему то у меня не один из примеров не пошел, а за отсутствием исходников, я не мог понять почему. Пробовал обраться к да не отвечает он. А неплохая библиотека, по крайней мере по тому что написано в документации присутствует тот необходимый минимум функций для шифрования-дешифрования, проверки ключа и сама библиотека весит не очень много – 184'832 Байт.
Т.е. меня не устроили эти библиотеки и я пошел на , в поисках истины. Нашел там упоминание про библиотеку для разработчиков – PGPsdk.
Описание архива
Скачать архив (51 K)Архив содержит следующие файлы:
В каталоге Main:
Внимание! Архив желательно распаковать в новую папку, так как файлы в нём лежат "просто так", не находясь в какой-либо директории!
Если появятся вопросы, возникнут проблемы или идеи, пишите мне! Буду только рад!
Романенко Владимир
Смотрите по этой теме:
Определение кратчайшего пути между двумя точками
| лес, дата публикации 02 июня 2003г. |
| Предпосылки. |
Недавно мне пришлось столкнуться с проблеммой нахождения кратчайшего пути между двумя точками. Существует несколько методов для решения этой задачи (метод Флойда, алгоритм Дейкстры и др.) Но описания этих методов мне показались сложными (и для меня - не математика - не совсем понятными), поэтому хотелось найти, что-нибудь более простое.
Эта тема уже поднималась на страницах нашего сайта (в рубрике Подземелье магов, А. Моисеевым ). Там была приведена реализация алгоритма Дейкстры. Но эта реализация оперирует не совсем понятными мне понятиями типов территорий (всего 6 типов) и, несомненно, предоставляя бОльшие возможности разработчику, становится сложнее по определению. Мне же было необходимо определить всего две вещи: существует ли в принципе какой-нибудь путь, и, если существует, найти кратчайший. (Как это происходит в известных играх Lines или Sokoban).
Здесь я хотел бы описать метод, разработанный мной и моим коллегой Манфредом Рауером (Manfred Rauer). Мы не претендуем на приоритет но, так как не являемся профессиональными математиками и не знаем известен ли уже этот алгоритм (во всяком случае я не нашел похожего описания), мы назвали его Алгоритмом Кегелеса-Рауера.
| Задача. |
Определить кратчайший путь между двумя точками на плоскости, обходя имеющиеся на ней препятствия.
| Алгоритм. |
Плоскость (поле) на которой следует определить путь представляется массивом чисел (integer), в котором преграда получает значение "-1", точка финиша (цель) - значение "1", а все остальные точки - значения "0". Затем от цели (элемент со значением "1") веером во все стороны, пока не встретиться преграда (-1) элементам массива, имеющим нулевое значение присваиваются значения на единицу большие, чем у соседнего элемента.
Выглядит это, приблизительно так, если поле символически изобразить таким образом: ####### # S # # ### # # # # F # ####### где # - преграда, S и F - точки старта и финиша; то массив будет иметь следующий вид: после инициализации: после заполнения значениями: -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 -1 -1 6 7 8 7 6 -1 -1 0 -1 -1 -1 0 -1 -1 5 -1 -1 -1 5 -1 -1 0 0 0 0 0 -1 -1 4 3 2 3 4 -1 -1 0 0 1 0 0 -1 -1 3 2 1 2 3 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
Теперь проверяется значение соответствующее точке начала движения. Если оно равно 0 - то пути нет, а если оно имеет какое-то значение, то остается проследовать по числам в массиве в убывающем порядке до цифры 1.
Все.
PS.
Есть 2 ограничения. Предполагается, что поле конечно, (например, ограничено со всех сторон преградами) и двигаться можно только по горизонтали или вертикали (диагональное движение отсутствует).
| Реализация. |
| // Я предполагаю, что размер поля не больше, чем 255 х 255 точек (или клеток), // в противном случае, передаваемые аргументы должны быть больших // целочисленных типов, напр., Word или Cardinal. // Кроме того предполагается, что переменные FeldHeight и FeldWidth, // определяющие размеры поля, объявлены как глобальные, если нет, то их // тоже нужно передать в процедуру, в качестве дополнительных аргументов procedure Find(RowStart, ColStart, RowFinish, ColFinish: Byte); var row, // строка массива col, // столбец массива i, // счетчик итераций циклов Number: Word; // количество элементов массива со значением 0 // для определения верхнего предела цикла замены // нулей рабочими значениями Val: Integer; // значение текущего элемента массива Map: array of array of Integer; // главный рабочий массив begin // Задаю размер массива, если размеры поля известны заранее (на этапе проектирования), // и используется статический двумерный массив, то эта комманда опускается SetLength(Map, FeldHeight, FeldWidth); // Заполняю массив значениями: преграда -1, цель (финиш) 1, все остальное 0 // Значения беруться из глобального массива ActiveFeld, определяющего профиль поля for col := 0 to FeldWidth - 1 do for row := 0 to FeldHeight - 1 do if (ActiveFeld[row, col] = '#') then Map[row, col] := -1 else Map[row, col] := 0; // В принципе поле ActiveFeld может быть бОльшим, чем проверяемый нами в данный // момент участок, тогда надо просто в выражении (ActiveFeld[row, col] = '#') задать // смещение для строк и столбцов массива ActiveFeld (ActiveFeld[row+X, col+Y] = '#') // Задаю значение для элемента массива соответствующего точке финиша Map[RowFinish, ColFinish] := 1; // На вский случай обнуляю переменные, хоть это и не обязательно, т. к. Delphi, // при их создании сама присвоит им нулевые значения. Но так понятнее. Number := 0; Val := 0; // Определяю количество незаполненных точек (клеток поля) - элементов // массива с нулевыми значениями. Это нужно для того, чтобы задать верхнюю границу // следующего цикла, заполняющего массив значениями. В любом случае число его // итераций не может превышать количества нулевых элементов for col := 0 to FeldWidth - 1 do for row := 0 to FeldHeight - 1 do if Map[row, col] = 0 then Inc(Number); // Заменяю нулевые значения массива соответствующими числами for i := 1 to Number do begin Inc(Val); for col := 1 to FeldWidth - 2 do for row := 1 to FeldHeight - 2 do if Map[row, col] = Val then begin if Map[row + 1, col] = 0 then Map[row + 1, col] := Val + 1; if Map[row - 1, col] = 0 then Map[row - 1, col] := Val + 1; if Map[row, col + 1] = 0 then Map[row, col + 1] := Val + 1; if Map[row, col - 1] = 0 then Map[row, col - 1] := Val + 1; end; end; // Определяю есть ли путь в принципе. Если пути нет (элемент массива с координатами // точки начала пути равен нулю), то выполняю какие-то действия (напр. Beep; Exit; как // приведено ниже) if Map[RowStart, ColStart] = 0 then begin Beep; Exit; end; // Сохраняю в переменной Val значение элемента массива, // соответствующего точке старта Val := Map[RowStart, ColStart]; // Прокладываю путь, последовательно спускаясь по точкам (клеткам поля) // от значения соответствующего точке старта к единице (точке финиша) // Процедура SetDirection() определяет конкретные действия например, закрашивание // клетки поля или перемещение элемента по полю. Параметром в нее передается // направление движения. Здесь предполагается, что процедура SetDirection // описана как procedure SetDirection (ADir: TDirection); а тип TDirection, как // type TDirection = (L, R, U, D); хоть это и избавляет от дополнительных ошибок, // но не обязательно, можно передавать параметрами числа, или символы. // Например, SetDirection('U'); для направления вверх. // Также предполагается, что SetDirection изменяет координаты ColStart и RowStart, // в противном случае изменение координат необходимо произвести в цикле While, // как это сделано в прилагаемой демонстрационной программе while (Val >= 2) do begin col := ColStart; row := RowStart; if Map[row, col] = Val then begin Dec(Val); if Map[row + 1, col] = Val then SetDirection(D); else if Map[row - 1, col] = Val then SetDirection(U); else if Map[ro, c + 1] = Val then SetDirection(R); else if Map[ro, c - 1] = Val then SetDirection(L); end; //if end; //while end; |
Программа работает очень просто. Тремя верхними кнопками задается элемент, который будет рисоваться при щелчке на поле (стенка, точка начала пути и точка конца пути). В случае ошибочно нанесенного элемента, его можно удалить нажав на кнопку Delete (с минусом) и щелкнув на удаляемом элементе. Кнопка Clear очищает поле, Fill in заполняет поле значениями массива (исключительно в демонстрационных целях) и Find - находит путь. Я разделил этот процесс на две процедуры для наглядности. Поскольку программа демонстрационная (читай упрощенная и не претендующая на оптимальность), я не добавлял в нее некоторые проверки на действия пользователя, по-этому просьба: не стирайте бордюр - это может привести к ошибкам.
С глубоким уважением ко всем рыцарям Королевства,
Скачать исходные коды и демо-проект: (190K)
Опыт использования ADO для доступа к базам данных форматов MS Access, xBase и Paradox
| Раздел Подземелье Магов |
Данная статья не является каким-либо учебным пособием, а просто попыткой обобщить некий опыт, полученный в течение некоторого времени при использовании ADO.
Подвигло меня на написание этой статьи то обстоятельство, что когда я приступал к этой работе (я имею в виду использование ADO), я размещал свои вопросы во многих конференциях, а ответов на них не получено до сих пор и, более того, эти же вопросы стали задаваться по новой, а ответов на них как не было, так и нет. На некоторые из них я отвечал, а потом подумал, что не все будут просматривать конференцию целиком, да и когда все сведено в одном месте оно и лучше. Кроме того, толковой литературы по использованию ADO практически нет никакой. Например, мне не удалось найти в солидных по объему книгах г-на Архангельского необходимую мне информацию. Или еще пример - Microsoft Press 'Справочник по OLE DB'. Здесь другой уклон - информации много, слишком много, а примеров никаких (но это вообще проблема справок от Microsoft - написано много, а примеров использования почти нет).
Надеюсь, что те сведения, которые я приведу здесь, помогут коллегам по цеху в решении его задач.
Особенности отладки DLL под Windows XP
Если вы работаете под операционной системой Windows XP, то при отладке DLL-библиотек у вас возникнут трудности. Они заключаются в том, что отладчик Delphi не загружает символы отладочной информации из библиотеки.Эта ошибка уже исправлена в Delphi 7, но если вы работаете с более ранними версиями, вам пригодится этот совет: выполните все приготовления к отладке, как было описано выше, запустите отладку. После того, как главное приложение запустится, переключитесь в Delphi и нажмите комбинацию клавиш Ctrl+Alt+M. В открывшемся окне списка загруженных модулей найдите ваш модуль, щелкните на нем правой кнопкой мыши и выберите пункт ReloadSymbol Table. В окне, которое появится, введите полный путь к вашей DLL и нажмите ОК. Таблица отладочных символов должна перезагрузиться и вы получите возможность устанавливать точки прерывания и следить за поведением вашего Shell extension.
Особенности реализации будильника
Входная строка CRON для синхронизированного таймера не хранится в экземпляре класса и не используется непосредственно для определения необходимости "тикнуть" в основном цикле менеджера. Вместо этого сразу производится разбор строки и преобразование во внутренний формат маски времени. Последний представляет собой массив множеств временных единиц (множество секунд, минут и так далее). Это позволяет выполнять операцию сравнения с текущим временем очень быстро - практически одноактная операция, не зависящая от длины исходной строки.Как и IntervalTimer, FixedTimer может работать в периодическом и старт-стопном режиме (параметр Mode=tmPeriod,tmStartStop в tmCreateFixedTimer). Но имеется еще дополнительная опция "уверенной синхронизации" (Mode=tmSureSync). В этом режиме производится проверка на пропуск предыдущего момента срабатывания. При этом, если даже в один прекрасный момент что-то помешало таймеру "тикнуть" (в течение более 1 с поток таймерного менеджера не получал управление), в следующую секунду он обязательно сработает "за тот раз". Время последнего срабатывания запоминается, его можно прочитать и установить.
Отладка MTS объектов
К сожалению, в справочной системе Delphi процесс отладки MTS объектов практически не освещен, что создает значительные трудности разработчикам. Хотя на самом деле, использование MTS позволяет достаточно просто проводить эту крайне необходимую операцию.Для этого необходимо выполнить следующие действия:
Для того, чтобы получить CLSID пакета, где находится компонент, можно воспользоваться все той же утилитой Component Services, страницей properties (Рисунок 9), где указан Application ID.
Внимание!
Вам необходим CLSID папки, в которую компонент установлен (dll file) CLSID, а не CLSID компонента. Например, если в ней установлено несколько компонентов, то для их отладки будет использоваться один и тот же идентификатор.
Отладка Shell extensions
После всех выполненных приготовлений вы можете нажать кнопку Run (F9) и запустить ваш Shell extension на отладку. Устанавливайте точки прерывания в нужных местах, используйте кнопки Program Pause и Program Reset при необходимости. Отладка Shell extensions более ничем не отличается от отладки обычных приложений Delphi. Не удивляйтесь, если после обрыва отладки проекта через «Program Reset», Windows Explorer будет загружаться сам. Это стандартная реакция Windows на ошибочное завершение процесса Explorer. Для нормального завершения процесса отладки вы можете воспользоваться способом, описанным ранее (через Пуск | Завершение работы). Windows Explorer - приложение многопоточное. Для каждого используемого Shell extension оно создает отдельный поток, в котором и работает с ним в дальнейшем. Поэтому не удивляйтесь, если в процессе пошаговой отладки вас внезапно перекинет в другой участок кода, где вы недавно отлаживались, а потом вернет снова на старое место. За вашими путешествиями сквозь потоки вы можете следить через окно Thread status, которое можно открыть через меню View | Debug Windows | Threads.Как вы заметили, отладка Shell extension не представляет из себя ничего сложного. Желаю вам удачи в разработке полезных и успешных расширений оболочки.
Ваши коментарии и замечания можете направлять дарности Особую благодарность хочу высказать Акжану Абдулину, благодаря которому я несколько лет назад начал разбираться с Shell extensions. Эта статья так же не избежала участи быть им откорректированной ;-). Посетите его и вы найдете там множество полезного и интересного материала.
Александр Тищенко
июль 2002г.
Перемещение TSplitter с клавиатуры или эмуляция мыши в VCL
| Раздел Подземелье Магов |
Правило:
В программировании одну и ту же задачу можно решить как минимум 3-мя способами имеющие разную эффективность.
Переподчинение окон MapInfo
После запуска MapInfo используйте оператор Set Application Window языка MapBasic для обеспечения перехвата управления Вашей программой-клиентом диалоговых окон и сообщений об ошибках программы MapInfo.Затем, в желаемой точке включения окна MapInfo в Ваше приложение передайте MapInfo оператор Set Next Document, за которым следует MapBasic-оператор, создающий окно.
Оператор Set Next Document позволяет Вам "переподчинять" окна документов. Синтаксис этого оператора требует указания уникального номера HWND элемента управления в Вашей программе. При последующем создании окна-документа MapInfo (с использованием операторов Map, Graph, Browse, Layout или Create Legend) создаваемое окно становится для окна порождающим объектом.
Примеры приведены из компонента но тоже самое можно выполнить и метолом Do непосредственно, но вы это уже я думаю поняли
ExecuteCommandMapBasic('Set Application Window %D', [FOwner.Handle]); ExecuteCommandMapBasic('Set Window Info Parent %D', [FOwner.Handle]); ExecuteCommandMapBasic('Set Next Document Parent %D Style 1', [FPanel.Handle]);
Примечание:
В компоненте это реализовано процедурой WindowMapDef которая ссылается на панель заданную свойством PanelMap.
Для каждого переподчиняемого окна необходимо передать программе MapInfo из Вашей программы пару операторов - оператор Set Next Document Parent, а затем оператор, создающий окно. После создания окна Вам может понадобиться запросить из MapInfo значение функции WindowID(0) - целочисленный ID-номер окна (Window ID) в MapInfo, так как многие операторы языка MapBasic требуют задания этого номера. Этот запрос выполняется на основе компонента следующим образом: WindowID := Eval('WindowID(%D)',[0]).AsInteger; Заметьте, что даже после переподчинения окна Карты, MapInfo продолжает управлять им. клиентская программа может не обращать внимания на сообщения о перерисовке, реализацию данной особенности я оставлю на потом.
Пересылка команд в программу MapInfo
После запуска программы MapInfo необходимо сконструировать текстовые строки, представляющие операторы языкa Map Basic.Если Вы установили связь с MapInfo, используя механизм управления объектами OLE (OLE Automation), передавайте командную строку программе MapInfo методом Do.
Например: FServer.Do('здесь команда MapBasic');
Примечание:
В компоненте это реализовано процедурой ExecuteCommandMapBasic, но в сущносте вызывается FServer.Do
При использовании метода Do программа MapInfo исполняет командную строку точно так как если б ее ввели в окне команд MapBasic.
Примечание:
Вы можете передать оператор в программу MapInfo, если этот оператор допустим окне MapBasic. Например, Вы не можете переслать MapBasic-оператор Dialog, поскольку его использование не разрешено в окне MapBasic.
Для определения допустимости использования оператора языка MapBasic в окне MapBasic обратитесь к Справочнику MapBasic или откройте Справочную систему; искомая информация находится под заголовком "Предупреждение". Например, в Справке по оператору Dialog дано следующее ограничение: "Вы не можете использовать оператор Dialog в окне исполнения (такие, как For..-Next и Goto), не разрешены для исполнения в окне MapBasic.
Первые шаги в построении платформы
Итак, мы имеем некоторый задел, чтобы решить самую первую задачу настройщика - создать таблицу клиентов. Однако, прежде чем создавать таблицы, научимся сначала загружать системную базу данных и просматривать состав пользовательской базы данных, для чего создадим несложную форму для отображения информации о пользовательской базе данных. Когда я попробовал изложить идею задач загрузки и сохранения информации при работе в режиме конфигуратора, делая "вырезки" из существующей платформы, то после целого дня работы убедился, что это невозможно, - слишком велик программный код, и читатель сразу бы запутался. А если бы я попробовал при этом еще все объяснить, то никогда бы эту статью не закончил. Поэтому пришлось избрать путь создания небольших приложений сугубо для учебных целей. Первое из них мы назовем конфигуратором.Наш конфигуратор будет делать очень простую работу: загружать урезанную информацию о таблицах пользовательской базы данных и давать возможность просматривать структуру таблиц. Тем самым не будем пока решать довольно непростую задачу обеспечения целостности базы данных, возникающую при ее реконструкциях. Тем не менее, позже мы "научим" простой конфигуратор создавать поля и таблицы, и, если хватит духу, то проводить модификацию, т.е. реконструкцию базы данных. Последнее, впрочем не обязательно делать, т.к. читатель это сам легко сможет реализовать, если поймет, как делаются первые две задачи. Далее перейдем к составлению запросов, сохраняемых в системной базе данных, что завершит основной цикл функциональности платформы.
Работоспособный проект для Delphi 7 приведен в архиве DPlatform.zip. В этом архиве, в папке DbBackup расположен архив базы данных для MSSQL Server 2000. Для запуска приложения нужно этот архив базы данных развернуть на доступном MS SQL Server 2000 и затем на главной форме приложения (файлы F_Configurator.dfm и F_Configurator.pas) компоненту Database подключить к этой базе данных, создав соответсвующий псевдоним BDE. Детали этого процесса пояснять ну буду, скажу лишь, что база данных создана на SQL Server 2000 с кодировкой 1251 и сортировкой, чувствительной к регистру, что очень важно иметь ввиду при установке базы данных. Ясно, что ваш сервер баз данных должен позволять восстанавливать базу данных из приведенного архива, т.е. иметь соответствующие кодировку и сортировку. Поясним, как работает наш конфигуратор, главная форма которого называется ConfiguratorFr.
После запуска приложение ничего не делает: оно ждет нажатия кнопки DbInterface, после чего происходят главные события, показанные в листинге 4.
Листинг 4. Создание экземпляра TDbInterface и загрузка информации в память.
| procedure TConfiguratorFr.Button2Click(Sender: TObject); Var k, i : Integer; wTabSheet : TTabSheet; wListBox : TListBox; wpTTableInfo : pTTableInfo; wpTInfoCategory : pTInfoCategory; wTFbTypeGroup : TFbTypeGroup; begin // Создать объект FDbInterface FDbInterface := TDbInterface.Create(nil); // Загрузить информацию из системной БД FDbInterface.DatabaseName := Database.DatabaseName; // Список категорий информации TbDbTypeComboBox.Items.Clear; TbDbTypeComboBox.Items.Assign(FDbInterface.FbDbTypeList); TbDbTypeComboBox.Sorted := True; // Настройка списка групп данных TypeGroupCmBox.Items.Clear; for wTFbTypeGroup := Low(TFbTypeGroup) to High(TFbTypeGroup) do TypeGroupCmBox.Items.AddObject(apTypeGroupNames[wTFbTypeGroup], TObject(wTFbTypeGroup)); // Показать состав загруженной информации for k:=0 to FDbInterface.InfoCategoryList.Count-1 do begin wpTInfoCategory := pTInfoCategory(FDbInterface.InfoCategoryList[k]); if wpTInfoCategory.sTFbDbType in [icAll, icNoCateg, icVirtual] then Continue; wTabSheet := TTabSheet.Create(FPageControl); wTabSheet.PageControl := FPageControl; wTabSheet.Caption := wpTInfoCategory.sInfoDescr; // Запомним ссылку для последующего использования wTabSheet.Tag := Integer(wpTInfoCategory); wListBox := TListBox.Create(Self); wListBox.Parent := wTabSheet; wListBox.Align := alClient; wListBox.OnClick := ListBoxClick; for i:=0 to FDbInterface.TablesList.Count-1 do begin wpTTableInfo := pTTableInfo(FDbInterface.TablesList[i]); if wpTTableInfo.spTInfoCategory <> wpTInfoCategory then Continue; wListBox.Items.AddObject(wpTTableInfo.sTableAttr.Values['sTableCaption'], TObject(wpTTableInfo)); end; end; Button2.Enabled := FDbInterface = nil; Button3.Enabled := FDbInterface <> nil; end; |
Сначала создается объект FDbInterface FDbInterface := TDbInterface.Create(nil).
В конструкторе этого объекта процедура CreateFbObjects обеспечивает создание всех необходимых списков, а также выполняется инициализация типов данных. Инициализация базовых типов проводится функцией Init_TFbFieldArray, которая заполняет массив FFbFieldArray информацией в соответствии с тем, как разработчик установил список поддерживаемых типов. Сначала производится стандартное заполнение информации в каждом элементе массива FFbFieldArray:
| for wTFieldType := Low(TFieldType) to High(TFieldType) do begin FFbFieldArray[wTFieldType].sType := wTFieldType; FFbFieldArray[wTFieldType].sSize := 0; FFbFieldArray[wTFieldType].sBytes := capAllTypes[wTFieldType].sBytes; FFbFieldArray[wTFieldType].sInc := 0; FFbFieldArray[wTFieldType].sDescr := capAllTypes[wTFieldType].sDescr; // Эти типы включены в систему if wTFieldType in [ftAutoInc, ftString, ftMemo, ftBlob, ftInteger, ftFloat, ftDateTime, ftUnknown] then FFbFieldArray[wTFieldType].sInc := 1; // ..а для этих типов - особые условия нужны // apDATE_TIME - признак разделения данных типа ДАТА и ВРЕМЯ with FFbFieldArray[wTFieldType] do case wTFieldType of ftDate : begin if apDATE_TIME then begin sInc := 1; sDescr := 'Дата'; end; sBytes := SizeOf(TDateTime); end; ftTime : begin if apDATE_TIME then begin sInc := 1; sDescr := 'Время'; end; sBytes := SizeOf(TDateTime); end; end; end; |
Кроме того, платформа обеспечивает поддержку раздельного учета типов ftDateTime, ftDate, ftTime непосредственно в приложении, т.к. MS SQL Server такое разделение не поддерживает. Применять или нет разделение этих типов, - определяется глобальной переменной булевского типа apDATE_TIME. При желании этот параметр может быть включен в число настроек, что и сделано в штатной версии описываемой платформы. После инициализации базовых типов формируется список FFbFldGroupList, содержащий ссылки на структуры TFbCommonType, причем эти структуры создаются только для тех типов базовой группы данных, которые реально поддерживает платформа, для чего анализируется поле sInc конкретного элемента массива FFbFieldArray. Эта работа выполняется функцией Init_FbFldGroupList:
| for wTFieldType := Low(TFieldType) to High(TFieldType) do begin if FFbFieldArray[wTFieldType].sInc <> 1 then Continue; New(wpTFbCommonType); New(wpTFbBaseType); wpTFbCommonType.FbTypeGroup := FldGroup; wpTFbBaseType^ := FFbFieldArray[wTFieldType]; wpTFbCommonType.FbFld := wpTFbBaseType; FFbFldGroupList.AddObject(wpTFbCommonType.FbFld.sDescr, TObject(wpTFbCommonType)); end; |
Вернемся, однако, к работе обработчика TConfiguratorFr.Button2Click.
Следующим шагом является подключение интерфейса FDbInterface к серверу базы данных, что выполняется программным кодом: // Загрузить информацию из системной БД FDbInterface.DatabaseName := Database.DatabaseName При этом срабатывает внутренняя процедура компоненты TDbInterface
Procedure TDbInterface.Set_DatabaseName(Value : String), где через параметр Value передается имя псевдонима базы данных приложения. В этой процедуре сначала производится загрузка в память информации из системной базы данных процедурой LoadSystemDatabaseInfo, а затем завершается процесс инициализации всех типов системы последовательным выполнением процедур Get_PickTypes_From_Database, Init_FbRefGroupList, Init_FbLUpGroupList.
Обратите внимание, что во всех этих процедурах используется обращение к процедуре Update_FbCommonTypeList, реализующей обновление списка FFbCommonTypeList комбинированных типов. Надо признать, что процедуру Update_FbCommonTypeList следовало бы использовать только один раз, после завершения формирования всех частных списков для отдельных групп данных. Но так сделано для того, чтобы обеспечить целостность списков комбинированных типов при манипуляции со структурой пользовательской базы данных в конфигураторе. Вероятно, есть более изящное решение этой задачи, которое могут использовать те читатели. Описание работы процедуры LoadSystemDatabaseInfo мы пока отложим, а работа остальных процедур (Get_PickTypes_From_Database, Init_FbRefGroupList, Init_FbLUpGroupList) очень проста.
Так как на главной форме нашего конфигуратора предусмотрено отображение информации из выбранных структур таблицы и поля, то производится заполнение следующих списков: выпадающего списка категорий информации TbDbTypeComboBox, заполняется на основании списка FDbInterface.FbDbTypeList, выпадающего списка групп данных TypeGroupCmBox, заполняется на основании списка apTypeGroupNames, имеющего в приложении как массив-константа.
Затем производится создание страниц объекта FPageControl. Их количество определяется количеством категорий информации платформы. В данном случае плафторма создает 6 страниц, согласно списку TFbDbType, причем для категорий icVirtual, icAll и icNoCateg страницы не создаются. На каждой странице размещается объект TListBox, в который заносится список названий таблиц соответствующей категории информации, причем в TListBox запоминаются также ссылки на соответствующие структуры TTableInfo, созданные при загрузке приложения.
Итак, наш конфигуратор готов к работе.
Рассмотрим, как он выполняет типовые операции, для которого создавался.
Первый проект.
После того как вы установили MapX сделаем свой первый простой проект, вот что у меня вышло для начала :
Согласитесь - для начала не плохо.
Итак приступим:
Положим компонент Tmap на форму. Тут я сделаю маленькое отступление - обычно MapX поставляется в составе приложения MapXTreme, которое в свою очередь является сервером для хранения карт, что-то вроде централизованного хранилища картографической информации, и если у вас выйдет такая ошибка :
Итак пришла пора загрузить карту - для этого в MapX служит объект Layers который представляет собой коллекцию слоев на карте : Вот как можно добавить слои (в примере они загружаются в FormCreate):
| FileMapper := ExtractFilePath(ParamStr(0)) + 'Map\Республика.TAB'; MapX.Layers.Add(FileMapper,2); FileMapper := ExtractFilePath(ParamStr(0)) + 'Map\Реки_полигоны.TAB'; MapX.Layers.Add(FileMapper,1); |
У объекта Layers есть метод Add в котором указывается таблица MapInfo и положение слоя на карте, причем чем меньше положение слоя тем слой выше на карте. Ну а органы управления картой (приближение,уменьшение,сдвиг и т.д) управляются свойствами MousePointer - вид курсора и CurrentTool - текущий инструмент;
В своем примере я применил следующие инстурменты Стрелочка (стандартный инструмент по умолчанию) MapX.MousePointer := miDefaultCursor; MapX.CurrentTool := miArrowTool; Рука (инструмент для перемещения карты) MapX.MousePointer := miPanCursor; MapX.CurrentTool := miPanTool; Лупы + и - (инструмент для маштабирования карты) MapX.MousePointer := miZoomOutCursor; MapX.CurrentTool := miZoomOutTool; //--- MapX.MousePointer := miZoomInCursor; MapX.CurrentTool := miZoomInTool; Итак, для начала мы разобрались как загружать карту в Tmap и как производить простейшие манипуляции на карте. В следующей части мы начнем более глубоко изучать MapX, научимся создовать собственные инструменты, манипулировать с единицами измерений и проекциями и т.д. До встречи !
Скачать (demo-проект + карты) (1M)
С уважением к коллегам, .
PGPSDK - Легкий путь к шифрованию
| Раздел Подземелье Магов | ний Дадыков, дата публикации 12 апреля 2002г. |
Иногда бывает нужно прикрутить к своей программе какое-нибудь шифрование. Для этих целей разработаны кучи алгоритмов шифрования, дешифрования, электронной подписи и т.п., основанных на различных математических аппаратах. Мало того – необходимо реализовать этот алгоритм. Но мы как кульные программеры не будем этого делать – а возьмем готовую библиотеку PGPsdk. Я не буду повторять классиков [2], что для реальных приложений использовать самодельные шифры не рекомендуется, если вы не являетесь экспертом и не уверены на 100 процентов в том, что делаете. Отговаривать же Вас от разработки собственных шифров или реализации какого-либо стандарта тоже не суть этой статьи, здесь пойдет речь о том, как быстро и правильно реализовать в своих приложениях защиту от посторонних глаз и, самое главное - не обмануться.
В моем приложении уже использовалось шифрование от PGP, ДОСовская, работало через командные файлы (*.bat), что явилось весомым аргументом для выбора средства шифрования, все работало, но меня это не устраивало – ДОСовская версия PGP (5.0) затрудняло инсталляцию программы, поддержку и не имеет некоторых полезных вещей, нужных для расширения системы в будущем. Еще чем привлекала PGP – бесплатная для некоммерческих программ, генерация произвольного количества ключей и то что пакет PGP очень популярен и им пользуются большое количество людей, и Вам легко будет решить проблему защиты информации от посторонних глаз в своих приложениях и по моему защита с помощью PGP дает большое преимущество.
| Раздел Подземелье Магов | рь , дата публикации 17 апреля 2002г. |
Начну со слов благодарности в адрес Романенко Владимира, который поделился своими исходными текстами и мыслями по поводу написания Инспектора.
Все необходимые структуры и функции для работы со свойствами объекта содержатся в файле поставки Delphi TypInfo.pas он и будет первоисходником для написания собственного Инспектора.
Для удобства работы со свойствами распишем два класса: класс свойств Tprop
TProp = class PropertyInfo: TPropInfo; - структура информации о свойстве PropertyType: TTypeInfo; - структура типа свойства PropertyKind: TTypeKind; - тип свойства PropertyName: ShortString; - название свойства sEnumName: string; iEnumValue: integer; vValue: Variant; - значение свойства iIndex: integer; ……………… ………………. end; и класс самого объекта TpropObject (исходн. FObjIspector.pas). TPropObject = class(TObject) oObject: TObject; - собственно объект нашего мониторинга arProp: array of TProp; - массив свойств данного объекта arMetod: array of TProp; - массив методов данного объекта ………….. …………. end; Класс Tprop - хранилище данных одного конкретного свойства (метода), а TpropObject - полное описание нашего объекта.
Получение свойств и методов объекта происходит при добавлении объекта в инспектор: procedure TPropObject.SetObject(const Value: TObject); var pProps: PPropList; nProps, i, iProp, iMetod: Integer; objTemp: TObject; begin oObject := Value; // Получаем количество Properte nProps := GetTypeData(oObject.ClassInfo).PropCount; GetMem(pProps, sizeof (PPropInfo) * nProps); try // Получаем список Property nProps := GetPropList (oObject.ClassInfo, [tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray],pProps); iProp := 0; iMetod := 0; // Заполняем данные по Property for i := 0 to nProps - 1 do if IsPublishedProp(oObject,pProps[i]^.Name) then if pProps[i]^.PropType^^.Kind = tkMethod then begin // Обрабатываем методы SetLength(arMetod,iMetod + 1); arMetod[iMetod] := TProp.Create; arMetod[iMetod].PropInfo := pProps[i]; Inc(iMetod); end else begin // Обрабатываем свойства SetLength(arProp,iProp + 1); arProp[iProp] := TProp.Create; arProp[iProp].PropInfo := pProps[i]; case arProp[iProp].PropertyKind of tkClass: begin objTemp := GetObjectProp(oObject,arProp[iProp].NameProperty); if objTemp<>nil then arProp[iProp].vValue := '(' + objTemp.ClassName + ')'; end; tkInterface: ; else arProp[iProp].vValue := GetPropValue(oObject,arProp[iProp].NameProperty); end; Inc(iProp); end; finally FreeMem(pProps); end; end;
Еще одним важным моментом при инспектировании свойств какого либо объекта является отслеживание изменений данного объекта на форме моделирования (редактирования). Наш инспектор должен быть оповещен о происходящих изменениях на форме. Для мониторинга изменений перекроем оконную процедуру у формы моделированияю Для этого в нашем инспекторе служит процедура SetWnd:
procedure TfmObjIspector.SetWnd(const Value: THandle); begin WndHandle := Value; // Устанавливаем новую процедуру окна для формы моделирования WndProcPtr := MakeObjectInstance(WndMetod); OldWndProc := Pointer(SetWindowLong(WndHandle,GWL_WNDPROC,integer(WndProcPtr))); end; Собственно новая оконная процедура выглядит так: procedure TfmObjIspector.WndMetod(var Msg: TMessage); // Обработчик сообщений для формы моделирования begin // Перечитаем наши проперти ReReadProperty; // и выполним старую оконную процедуру with Msg do Result := CallWindowProc(OldWndProc,WndHandle, Msg, wParam, lParam); end;
При уничтожении формы инспектора необходимо восстановить старую оконную процедуру у формы моделирования в противном случае последствия могут быть непредсказуемы. Восстанавливаем оконную процедуру:
procedure TfmObjIspector.FormDestroy(Sender: TObject); begin // Если была подмена оконной процедуры - вернем все в зад // иначе бед не оберешься if OldWndProc<>nil then begin SetWindowLong(WndHandle,GWL_WNDPROC,integer(OldWndProc)); FreeObjectInstance(WndProcPtr); end; inherited; end; Отрисовка свойств и методов на форме инспектора малоинтересный процесс позиционирования линий и текства на компонентах TpaintBox поэтому все это вы найдете в прилагаемых исходный текстах. Исходные тексты содержат набросок инспектора объектов, компонент Timage иммитирующий designtime отрисовку компонента и тестовую форму.
В представленном листинге не реализовано редактирование свойств и методов.
Все предложения, пожелания, ругань и т.д. приму с благодарностью. С уважением ко всем дочитавшим до этого места,
Разинкин И.В.
Скачать проект (13 K)
Смотрите по этой теме:
Изначально цель методик обнаружения ошибок
| Раздел Подземелье Магов |
Высокую степень безопасности данных обеспечивают алгоритмы контроля за достоверностью информации, использующие циклические избыточные коды (Cyclic Redundancy Code - CRC).
Использование CRC представляет собой сверхмощный метод обнаружения ошибок.
кода,
Для простоты считайте CRC остатком от деления БОЛЬШОГО бинарного числа (передаваемых данных) на число, в зависимости от разряда старшего бита этого числа выделяют CRC16 и CRC32.
Теория этого дела весьма обширна и хорошо описана в литературе, но думаю, большинство читателей этой статьи гораздо больше волнует её практическая реализация.
Алгоритм получения CRC32 такой:
И, конечно, тестовая программка:
program Crc32; {$APPTYPE CONSOLE} uses SysUtils,Classes,IcsPlus; var FS: TFileStream; Crc: LongWord; Begin if ParamCount<>1 then begin WriteLn('Crc32 v1.0 Copyright (c) 2001 by Andrew P.Rybin [magicode@mail.ru]'); WriteLn(' Usage: crc32 filename'); EXIT; end; Crc32Initialization; FS:= TFileStream.Create(ParamStr(1),fmOpenRead); try Crc:=Crc32Stream(FS,0); WriteLn('Crc: ',IntToHex(Crc,8),' = ',Crc); finally FS.FREE; end; End.
В файле содержится используемый мною в работе модуль IcsPlus.pas, который включает вышеописанные функции, и тестовая программка. Автор будет признателен за возможные советы, пожелания и bugfix'ы.
Andrew P.Rybin
Специально для
Подготовка проекта Delphi для отладки с Windows Shell
Как и для отладки любой другой DLL вы должны указать Host Application для вашего Shell extension. В адресное пространство этого приложения ваш Shell extension будет загружен. В нашем случае таким приложением является Windows Explorer. Зайдите в меню Run | Parameters..., нажмите кнопку Browse и выберите файл Explorer.exe из директории Windows. Не спешите запускать отладку, впереди есть еще много значительных нюансов.Вы должны включить всю необходимую отладочную информацию в ваш проект. Для этого перед компиляцией откройте окно «Project Options» (пункт меню Project | Options...), перейдите на закладку «Linker» и в группе «Exe and Dll Options» пометьте флажек «Include remote debug symbols». Он включает генерацию специальных данных для удаленной отладки, которые так же необходимы для отладки COM-приложений. После окончания работ над отладкой вашего Shell extension не забудьте отключить эту возможность, так как она значительно увеличивает размер модуля и создает еще больший по размерам файл с расширением *.rsm, в котором и хранятся символы удаленной отладки. Так же для удобства отладки включите флажек «Use debug DCUs» на закладке «Compiler» диалога «Project Options». Это позволит вам следить за внутренней работой модулей, которые небыли включены в список модулей вашего проекта.
Так же вы не должны забывать о доступности исходных текстов вашего Shell extension для отладчика Delphi. Они должны находиться в текущей для Delphi директории или к ним должен быть прописан путь в диалоге Project | Options | Directories/Conditionals, пункт – «Debug Source Path».
После выполнения всех действий по настройке свойств проекта вы должны полностью перекомпилировать ваш проект (через пункт меню Project | Build...).
Подготовка Windows Explorer к работе под отладчиком
Носителем функциональности Shell является приложение Windows Explorer. Вы можете увидеть на экране своего компьютера такие объекты, как Desktop, Taskbar, окна папок файловой системы. Все это реализовано приложением Windows Explorer, и Вы можете увидеть это приложение в Task Manager.Сопоставленный ему процесс называется Explorer.exe. Там же вы можете увидеть, что у вас иногда запущено несколько экземпляров этого процесса. Не удивляйтесь - все дело в настройках Windows, что и будет показано далее.
Windows Shell автоматически выгружает динамическую библиотеку, когда внутренний счетчик её использования равен нулю, но это происходит только по истечении определенного периода времени. Это сделано для ускорения работы оболочки, но не всегда удобно при написании и отладке Shell extensions в пределах одной операционной системы - при компиляции уже зарегистрированного Shell extension его файл может оказаться заблокированным для записи. Для операционных систем версий ниже Windows 2000 вы можете уменьшить этот период с помощью добавления нижеследующей (following) информации в реестр: HKLM Software Microsoft Windows CurrentVersion Explorer AlwaysUnloadDll Не забывайте отключать эту возможность после завершения отладочных работ над вашим Shell extension, так как она плохо сказывается на производительности Windows.
В любой операционной системе можно применить следующий метод для запуска Windows Shell под отладкой:
При отладке Shell extensions под управлением Windows NT/2000/XP вы можете настроить запуск нескольких экземпляров Windows Explorer (отдельный экземпляр под Task Bar, под каждое окно с содержимым папок или дисков). В результате вы сможете отлаживать ваши Shell extensions не выгружая при этом Task Bar и Desktop, что намного удобнее. Чтобы включить эту возможность вы должны добавить нижеследующую информацию в реестр:
HKEY_CURRENT_USER\ Software\ Microsoft\ Windows\ CurrentVersion\ Explorer\ DesktopProcess(REG_DWORD) = 1 Чтобы это значение начало действовать вы должны выполнить Log off и затем Log on. Не забывайте отключать эту возможность после завершения отладочных работ над вашим Shell extension, так как она плохо сказывается на производительности Windows.
Подготовка.
Итак, начнём с того, что нам необходимо сделать перед тем, как непосредственно начать использовать мощь технологии WMI в своих программах:Подгружаемые модули (plugins) в Delphi
| Раздел Подземелье Магов | Трофимов Игорь , дата публикации 01 августа 2000г. |
Введение
Когда я впервые столкнулся с задачей организации подгружаемых в RunTime модулей (plugins) для Delphi-программ, ответ нашелся достаточно быстро. Как это иногда бывает в подобных ситуациях, я не особо задумался о том, как подобную задачу решают другие разрабточики.
Точнее, я понимал, что многие используют достаточно очевидный метод - обращение к функциям подгружаемой DLL с оговоренными именами. Этот подход кажется очевидным и простым, если задача, возлагаемая на plugin проста. Типичные примеры - вниешние кодеки, разборщики пакетов и т.д.
Однако описанный подход имеет ряд недостатков, зачастую довольно существенных. Я опишу их в следующем разделе.
В то же время меня часто спрашивали, каким образом можно создать удобный механизм plugin'ов и я описывал свой метод. Метод, предлагаемый мною, основан на использовании механизма, которым пользуется сама Delphi IDE - пакеты (packages).
| Проблема (недостатки DLL-plugin'ов) |
Все используемые модули компилируются в DLL
Представьте, что вам надо сделать подключаемый модуль, который выводит форму с настройками. Как только вы впишете в DLL выражение uses Forms,... модуль Forms, а также все модули, используемые модулем Forms будут прилинкованы к вашей DLL, что катастрофически увеличит ее размер. Представьте теперь, что вам нужно подключать несколько plugin'ов, каждый из которых будет предоставлять форму или вкладку для редактирования параметров. Как писал классик, душераздирающее зрелище...
Модули дублируются
Предыдущий недостаток является количественным, т.е. просто увеличивающим размер проекта. Но из него вытекает качественный недостаток. Рассмотрим его на примере. Пусть вам надо создать подгружаемые разборщики пакетов. Вы определяете абстрактный класс TParser в модуле UParser и хотите, чтобы все разборщики наследовали от него. Но для того, чтобы вы могли описать в DLL потомок от TParser, вы должны включить модуль UParser в список uses для DLL. А для того, чтобы основная программа могла обращаться с TParser и его потомками, в нее также должен быть включен uses UParses,.... Неприятность заключается в том, что эти модули будут находиться в памяти дважды и тот TParser, о котором знает основная программа не совпадает с тем, который знает plugin.
| Задача (чего бы нам хотелось) |
| Средство (пакеты и функции для работы с ними) |
Основной особенностью пакетов является то, что не включают в себя код, которым пользуются. Т.е. если некоторые модули используют большую библиотеку функций и классов, то можно потребовать их наличия, но не включать в пакет. Вы спросите, что же тут нового, ведь обычные модули тоже не включают в .dcu-файл весь используемый код? А нового здесь то, что dpl-пакет является полноправной DLL специального формата (т.е. с оговоренными разработчиками Delphi именами экспортируемых процедур). При загрузке пакета в память автоматически устанавливаются связи с уже загруженными пакетами, а если загружаемый пакет требует наличия еще каких-то пакетов, то загружаются и они. Кроме того, в отличие от обычных модулей, программа, использующая модули из внешнего пакета тоже не обязана включать его код. Таким образом, можно писать EXE-программы размеров в несколько десятков килобайт (естественно, будет требоваться наличие на диске соответствующего пакета, который затем подгрузится).
Функции для работы с пакетами сосредоточены в модуле SysUtils. Нас будут интересовать следующие из них: function LoadPackage(const Name: string): HMODULE; Загружает пакет с заданным именем файла в память, полностью подготавливая его для работы. procedure UnloadPackage(Module: HMODULE); Выгружает заданный пакет из памяти.
Кроме этих функций в модуле SysUtils описаны также структуры заголовков пакета, функции получения информации о содержимом пакета и еще несколько служебных функций, разобраться с которыми предоставляется читателю.
| Минусы |
| Метод (что делаем, и что получим) |
Остался единственный вопрос - как основная программа получит ссылки на объекты или на классы (class references) нужного типа? Для этого в интерфейсном модуле хранится диспетчер plugin'ов или, в простейшем случае, просто TList, в который каждый модуль заносит ставшие доступными классы. В более развитом случае диспетчер классов может обеспечивать поиск подгруженных классов, являющихся потомками заданного, приоритеты при загрузке, и.т.д.
Ясно, что мы достигли поставленой цели - избыточности кода нет (при условии, что все библиотеки, в том числе и стандартные библиотеки VCL, используются в виде пакетов), написание plugin'а упрощено до предела. Чего можно добиться еще?
А можно добиться еще более интересной вещи. Если мы всю основную програму поместим в пакет, а EXE-файл будет включать в себя только процедуру создания и открытия основной формы, то внешний plugin может получить полный доступ ко всем модулям программы, в том числе и к главной форме. Таким образом мы можем написать plugin, который самостоятельно, без каких-либо усилий со стороны головной программы, поместит свой пункт в главное меню и кнопку на панель инструментов, по команде которых будет вызываться внешний код. Это то, ради чего стоит задуматься над использованием предложенного метода - положив в определенный каталог маленький (в нем только ваш код) plugin, вы добавляете к программе очередную возможность, не перекомпилируя основной программы.
| Подгружаемые модули (plugins) в Delphi: Пример 1 |
Первый пример демонстрирует возможности plugin'а, реализующего потомка заданного класса. Поразмышляв о том, что пример не должен быть ни слишком сложным, ни слишком надуманным, я решил что подходящим кандидатом будет класс, выводящий строки текста в некотором виде. Подобный прием может пригодиться, например, если вы пишете почтовый клиент и хотите сделать возможным экспорт данных из него в файлы разных форматов или в другой клиент.
Мы создадим один предопределенный класс, экспортирующий строки в текствый файл и один внешний plugin, содержащий класс, который умеет экспортировать строки....ну, скажем, в HTML. Экспорт в Excel или в БД выведет нас за тонкую границу примера.
Абстрактный класс
Итак, рассмотрим определение абстрактного класса:
| unit UExporter; { ============================================= } interface { ============================================= } type TExporter = class public class function ExporterName: string; virtual; abstract; procedure BeginExport; virtual; abstract; procedure ExportNextString(const s:string); virtual; abstract; procedure EndExport; virtual; abstract; end; { ============================================= } implementation { ============================================= } end |
Менеджер классов
Следующим номером нашей программы будет менеджер загруженных классов. Как я и говорил, это может быть просто TList:
| unit UClassManager; { ============================================= } interface { ============================================= } uses Classes; type TClassManager = class(TList); function ClassManager: TClassManager; { ============================================= } implementation { ============================================= } var Manager: TClassManager; function ClassManager: TClassManager; begin Result := Manager; end; { ============================================= } initialization { ============================================= } Manager := TClassManager.Create; { ============================================= } finalization { ============================================= } Manager.Free; end |
В этом коде, по моему, пояснять нечего.
Экспорт в простой текстовый файл
Теперь напишем стандартный потомок от TExporter, обеспечивающий вывод строк в обычный текстовый файл.
| unit UPlainFileExporter; { ============================================= } interface { ============================================= } uses Classes, UExporter; type TPlainFileExporter = class(TExporter) private F: TextFile; public class function ExporterName: string; override; procedure BeginExport; override; procedure ExportNextString(const s:string); override; procedure EndExport; override; end; { ============================================= } implementation { ============================================= } uses Dialogs, SysUtils, UClassManager;{ TPlainFileExporter } procedure TPlainFileExporter.BeginExport; var OpenDialog : TOpenDialog; begin OpenDialog := TOpenDialog.Create(nil); try if OpenDialog.Execute then begin AssignFile(F,OpenDialog.FileName); Rewrite(F); end else Abort; finally OpenDialog.Free; end; end; procedure TPlainFileExporter.EndExport; begin CloseFile(F); end; class function TPlainFileExporter.ExporterName: string; begin Result := 'Экспорт в текстовый файл'; end; procedure TPlainFileExporter.ExportNextString(const s: string); begin WriteLn(F, s); end; { ============================================= } initialization { ============================================= } ClassManager.Add(TPlainFileExporter); { ============================================= } finalization { ============================================= } ClassManager.Remove(TPlainFileExporter); end |
Основная программа
Из основной программы я приведу только несколько методов, иллюстрирующих использование внешних пакетов, а полный текст вы найдете в архиве, прилагаемом к статье.
| procedure TMainForm.RefreshPluginList; var i : Integer; begin PluginsBox.Items.Clear; for i := 0 to ClassManager.Count - 1 do PluginsBox.Items.Add(TExporterClass(ClassManager[i]).ExporterName); end; |
Эта процедура просматривает список зарегистрированных классов (предполагается, что там только потомки TExporter) и выводит их "читабельные" имена в ListBox.
| procedure TMainForm.LoadBtnClick(Sender: TObject); begin PluginModule := LoadPackage(ExtractFilePath(ParamStr(0)) + 'HTMLPluginProject.bpl'); RefreshPluginList; end; |
| procedure TMainForm.UnloadBtnClick(Sender: TObject);begin UnloadPackage(PluginModule); RefreshPluginList;end; |
| procedure TMainForm.ExportBtnClick(Sender: TObject); var ExporterClass: TClass; Exporter: TExporter; i: Integer; begin if PluginsBox.ItemIndex < 0 then Exit; ExporterClass := ClassManager[PluginsBox.ItemIndex]; Exporter := TExporter(ExporterClass.Create); try Exporter.BeginExport; try for i := 0 to StringsBox.Lines.Count - 1 do Exporter.ExportNextString(StringsBox.Lines[i]); finally Exporter.EndExport end; finally Exporter.Free; end; end; |
Компиляция
Разверните архив в какой-то каталог ( например c:\bebebe :) ) и откройте группу проектов Demo1ProjectGroup.bpg. Использование группы полезно, так как вам часто придется переключаться между основной программой и двумя пакетами - это разные проекты. Я надеюсь, что если вы нажмете "Build All Projects" то все успешно скомпилится.
Поглядев на опции головного проекта, вы увидите, что на страничке Packages указано, какие из используемых пакетов не прилинковывать к exe-файлу. Следует отметить, что даже если вы включите туда только PluginInterfaceProject, то автоматом будут считаться внешними и все, используемые им пакеты - в нашем случае Vcl5.dpl. Зато если вы положите на основную форму какой-то компонент работы с BDE, то пакет VclDB5.bpl может быть прикомпилирован (с оптимизацией, естественно) к EXE-файлу.
Что еще можно сказать? Пожалуй, стоит отметить, что "возня" с пакетами нередко бывает утомительна и чревата "непонятными ошибками" вплоть до зависания Delphi. Однако все они в итоге оказываются следствием неаккуратности разработчика - ведь связывание на этапе выполнения это не простая штука. Поэтому следите, куда вы компилируете пакеты, следите за своевременной перекомпиляцией plugin'ов, если изменился абстрактный класс, следите, чтобы у вас на машине не валялось 10 копий dpl-пакета, потому как вы можете думать, что программа загрузит лежащий там-то и ошибетесь.
Еще. По умолчанию файлы .dcu кладутся вместе с исходниками, а пакеты - в каталог ($DELPHI)\Projects\Bpl. В примере настроки правильные - пакеты создадутся в каталоге исходников. Пожелания, вопросы, благодарности и ругань приму по адресу iamhere@ipc.ru. На все, кроме ругани постараюсь ответить.
Что еще можно сказать? Пожалуй, стоит отметить, что "возня" с пакетами нередко бывает утомительна и чревата "непонятными ошибками" вплоть до зависания Delphi. Однако все они в итоге оказываются следствием неаккуратности разработчика - ведь связывание на этапе выполнения это не простая штука. Поэтому следите, куда вы компилируете пакеты, следите за своевременной перекомпиляцией plugin'ов, если изменился абстрактный класс, следите, чтобы у вас на машине не валялось 10 копий dpl-пакета, потому как вы можете думать, что программа загрузит лежащий там-то и ошибетесь.
Еще. По умолчанию файлы .dcu кладутся вместе с исходниками, а пакеты - в каталог ($DELPHI)\Projects\Bpl. В примере настроки правильные - пакеты создадутся в каталоге исходников. Пожелания, вопросы, благодарности и ругань приму по адресу iamhere@ipc.ru. На все, кроме ругани постараюсь ответить.
Подведение итогов.
Таким образом, в настоящей статье и приведённых исходниках продемонстрирован "ручной" подход к реализации Инспектора объектов, а так же полная его (Инспектора) "русификация". Можно проанализировать все достоинства и недостатки данного подхода.Достоинства
Недостатки:
Но главное достоинство этого подхода - неплохое упражнение в алгоритмизации!
Получение и установка свойств источника
Теперь когда мы научились выводить отчет, расширим наши познания в области манипуляций отчетом, такими как получение параметров отчета и свойств источника данных.Свойства источника данных можно получить или установить через функции PEGetNthTableLogOnInfo и PESetNthTableLogOnInfo. Здесь надо отметить довольно тонкий момент, связанный с обработкой данных в CR. Источником данных может выступать любая СУБД как файловая, так и серверная, текстовый файл и т.п. В свою очередь к примеру из серверной СУБД данные можно получить через хранимую процедуру (stored procedure), представление (view), таблицу (table) или через набор таблиц которые обрабатываются уже внутри отчета. Поэтому используются различные API функции зависящие от возможностей источника.
Обратите внимание на название в именах функций - сокращение Nth обозначает, что функция вызывается для определенной таблицы.
Получение свойств через функцию довольно просто. Описываем структуру данных, передаем дескриптор задачи и порядковый номер таблицы. После вызова функции получаем заполненную структуру параметров.
| Синтаксис функции: function PEGetNthTableLogOnInfo (printJob: Word; tableN: Integer; var logOnInfo: PELogOnInfo): Bool; где, printJob - дескриптор задачи. tableN - номер таблицы. location - струкура со свойствами источника. Пример: PEGetNthTableLogOnInfo(FHandleJob, 0, lt); |
| // Чистим структуру. FillChar(lt, SizeOf(PELogOnInfo), 0); // Заполняем поле размера. lt.StructSize := SizeOf(PELogOnInfo); // Вызываем функцию для таблицы с порядковым номером 0 (ноль) PEGetNthTableLogOnInfo(FHandleJob, 0, lt); |
| type PELogonServerType = array[0..PE_SERVERNAME_LEN-1] of Сhar; PELogonDBType = array[0..PE_DATABASENAME_LEN-1] of Сhar; PELogonUserType = array[0..PE_USERID_LEN-1] of Сhar; PELogonPassType = array[0..PE_PASSWORD_LEN-1] of Сhar; PELogOnInfo = record StructSize: Word; ServerName: PELogonServerType; DatabaseName: PELogonDbType; UserId: PELogonUserType; Password: PELogonPassType; end; где, StructSize - размер структуры. Заполняется обязательно. ServerName - имя сервера или путь к файлу БД. DatabaseName - имя БД. UserId - пользователь. Password - пароль пользователя. |
| // Скопировать в поле ServerName путь к БД отчета. StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) + 'source_db.mdb'); // Установить параметры для таблицы 0 и только для нее. PESetNthTableLogOnInfo(FHandleJob, 0, lt, False); |
Получение параметров отчета
Теперь о том как получить параметры отчета с помощью которых производится управление.Используя PEGetNParameterFields вы получаете общее количество параметров в отчете. Передавая в функцию PEGetNthParameterField порядковый номер параметра получаем структуру с данными об имени, размере, значениях и т.п. Функция PEConvertPFInfoToVInfo позволяет получить значение параметра.
Функция PEGetNParameterFields имеет только один параметр - дескриптор задачи, в результате возвращается количество параметров. В примере показано как работать с параметрами:
| var ParameterInfo: PEParameterFieldInfo; ValueInfo: PEValueInfo; . . . // Получить количество параметров. CountParams:= PEGetNParameterFields(FHandleJob); if CountParams <> -1 then begin for i:= 0 to CountParams - 1 do begin // Запросить информацию о параметре i. PEGetNthParameterField(FHandleJob, i, ParameterInfo); ValueInfo.ValueType := ParameterInfo.valueType; // Получить значение параметра. PEConvertPFInfoToVInfo(@ParameterInfo.DefaultValue, ValueInfo.ValueType, ValueInfo); ... end; end; |
| uses COMAdmin_TLB; .... var MainCatalog : ICOMAdminCatalog; Apps : ICatalogCollection; ....... MainCatalog := CoCOMAdminCatalog.Create; //Create Main catalog // Getting Application folder Apps := MainCatalog.GetCollection('Applications') as ICatalogCollection; |
Данный фрагмент кода вам придется использовать практически всегда, поскольку для доступа к нужному вам элементу приходится перебирать все дерево элементов. Дело в том, что метод GetCollectionByQuery в интерфейсе ICOMAdminCatalog, который должен возвращать нужный вам элемент или коллекцию, пока не реализован.
После того, как вы получили интерфейс коллекции, необходимо обязательно вызвать метод Populate этого интерфейса. Дело в том, что метод GetCollection не читает список элементов коллекции и если вы попытаетесь обратиться к методам интерфейса без вызова этого метода, то увидите, что список пуст.
Найти нужный элемент в коллекции также можно только путем полного перебора всех его элементов, поскольку метод PopulateByQuery в интерфейсе (по крайней мере, на момент написания статьи) не реализован. В данном фрагменте в список помещаются имена всех компонентов, которые входят в коллекцию. Заметим, что поскольку свойство Item возвращает IDispatch, то используется приведение типов (неявный вызов функции QueryInterface).
| Apps.Populate; //Refresch Application folder contents Appcount := Apps.Count; //Applications count for i := 0 to AppCount -1 do begin //Put all application's names into the list App := ICatalogObject(Apps.Item[i]); List.Add(App.Name); end; |
Ниже приводится функция, полностью реализующая эту возможность.
| function GetApplicationsList(List: TStrings): boolean; var MainCatalog : ICOMAdminCatalog; Apps : ICatalogCollection; App : ICatalogObject; AppCount : integer; i : integer; begin try List.Text := ''; //Empty List; MainCatalog := CoCOMAdminCatalog.Create; //Create Main catalog // Getting Application folder Apps := MainCatalog.GetCollection('Applications') as ICatalogCollection; Apps.Populate; //Refresch Application folder contents Appcount := Apps.Count; //Applications count for i := 0 to AppCount -1 do begin //Put all application's names into the list App := ICatalogObject(Apps.Item[i]); List.Add(App.Name); end; result := true; except result := false; end end; |
| comps := ICatalogCollection(Apps.GetCollection('Components', app.Key)); comps.Populate; //Refresh list of components compsCount := comps.Count; //Components count for j := 0 to compsCount - 1 do begin //Put all componetes into list comp := ICatalogObject(Comps.Item[j]); List.Add(comp.Name); end |
Обратите внимание на то, что и здесь перед просмотром списка используется метод Populate. Ниже приводится полный текст функции.
| function GetComponentsList(ApplicationName : string; List: TStrings): boolean; var MainCatalog : ICOMAdminCatalog; Apps : ICatalogCollection; App : ICatalogObject; Comps : ICatalogCollection; comp : ICatalogObject; AppsCount, CompsCount : integer; i, j : integer; begin try List.Text := ''; //Empty List; MainCatalog := CoCOMAdminCatalog.Create; //Create Main catalog // Getting Application folder Apps := MainCatalog.GetCollection('Applications') as ICatalogCollection; Apps.Populate; //Refresch Application folder contents Appscount := Apps.Count; //Applications count for i := 0 to AppsCount -1 do begin //Search Application by name App := ICatalogObject(Apps.Item[i]); if App.Name = ApplicationName then begin // Application found //Getting aplication's components by application key (GUID) comps := ICatalogCollection(Apps.GetCollection('Components', app.Key)); comps.Populate; //Refresh list of components compsCount := comps.Count; //Components count for j := 0 to compsCount - 1 do begin //Put all componetes into list comp := ICatalogObject(Comps.Item[j]); List.Add(comp.Name); end end end; result := true; except result := false; end end; |
| Раздел Подземелье Магов | е дамы и господа, наконец, настало время, когда я решил написать статью, обещанную королевству около года назад. Зараннее извиняюсь за свой стиль, давно не приходилось писать что-нибудь большое на руском. Поводом к написанию статьи стали результаты моего решения для оптимизации поиска. Я приведу конкретную задачу, но использовать данную технологию поиска можно во многих задачах. Задача формулировалась так: Имеется список звонков или один звонок. Звонок содержит в себе тариф и номер, но заранее не известна длина тарифа. Например 845678606708 : 8-это международный код 45678 - тариф 606708-телефон. В базе тарифов могут присутствовать тарифы 45, 456, 45678 и нужно выбрать самый длинный (максимальный тариф). Соответственно поиск по индексу не подходит, необходим перебор вариантов, то есть для каждого звонка необходимо перебрать все тарифы. У меня было 500 тарифов и 100000 звонков. В результате получается 500*100,000=50,000,000 операций. Можно это сделать с оптимизацией, но все равно необходим перебор вариантов. У меня операция пересчета занимала 1 час. Поэтому я решил прикинуть тарифы в память, а поиск выполнять во время считывания звонка и записывать ID тарифа. Этим я убивал сразу 2 зайцев. Скорость поиска тарифа сокращалась почти до нуля, и упрощался алгоритм пересчета. Весь пересчет сводился к заурядному SQL-запросу плюс функция расчета цены. Но поскольку к скорости сохранения данных предъявляются весьма жесткие требования, алгоритм должен быть весьма быстрым! Я посмотрел различные источники, подумал о бинарных деревьях и решил, что мне это не подходит. Немного подумав, создал свое дерево, в нем каждый элемент дерева представлен одним байтом 0 до 9; разумеется, мне нужно всего 4 бита, но для операций сравнения удобней использовать весь байт. Вот пример узла дерева sNode = packed record Item: Byte; ID: Word; Point: Array of Word; end; Item - это элемент дерева от 0 до 9 Я выбрал динамический массив для хранения дерева как наиболее удобный и экономичный способ хранения. При использовани масива мы икономим 2 байта на указателе, это накладывает ограничение на количество элементов масива 65535. Если необходимо больше, то можно заменить индекс адресом. Но при этом обций размер масива увеличится в 3-4 раза.  При таком посторении дерева экономится память. То есть, для нахождения тарифа 82345 надо сделать 4 шага от корня и при каждом шаге проверять содержание дочерних элементов для нахождения нужной ветки. Если при построении дерева встречаются два похожих тарифа типа 82346, то добавляется только узел 6. Этим экономится много памяти. Все остальное вместе с примерами можно найти в архиве. Там релизован класс TsmallTree который имеет необходимые методы procedure AddArray(Var Tarif: Array of ShortString); строит дерево из массива procedure AddElement(Key: ShortString; ID: Cardinal); function Find(Key: ShortString): Word; procedure RecursiveBeat(AProc: TBuildNode); создает указатель на процедуру. procedure ShowTree; - вызывает эту процедуру для каждого узла(я использовал при отладке) В секцию public вынесены две переменные Step: Word; - а это как следует из названия шаг увеличения памяти. List: Array of sNode; - это само дерево Поскольку при построении дерева количество элементов обычно больше 100, то невыгодно прибавлять по 1 элементу (очень медленно). Поэтому я сделал, как обычно в этих случаях, свой менеджер, который при превышении границы массива прибавляет N элементов. Я советую величину шага ставить на порядок меньше элементов масива. То есть Array:1000 Step:100, Array:10000 Step:1000 , тогда нет торможения программы. У меня при 10000 элементах все работало нормально, но при 12000 начинались какие-то проблемы, возможно, это связано с теоретическим пределом в 65535 узлов дерева. В описании упоминаются два массива - один массив строк (исходный материал для построения), другой масив - это само дерево, не перепутайте! сентябрь 2001г. Специально для Скачать файлы проекта : |
table WIDTH="100%" BGCOLOR="#FAEBD7" CELLPADDING="3" CELLSPACING="0" >
Преамбула:
Однажды мне захотелось перемещать панели разделенные TSplitter с клавиатуры. Не удобно, при большом вводе пользоваться еще и мышью. Первая мысль, что пришла в голову, это изменить размеры у панели при нажатии определенных клавиш. PanelLeft.Width:=PanelLeft.Width-20; Сделал быстро и ... В общем получилась гадость. Все прыгало, мигало, в общем одна жуть.Ладно, решил пойти другой дорогой, т.е. другим методом. Решил сделать панель в виде полоски и ее перемещать. Форма изменялась как ей было и положено, но сама панель противно кривлялась. В общем тоже мало эстетичное зрелище.
Решил написать наследника от TSplitter, но уже с возможностью эмуляции клавиатуры. Поковырялся, поковырялся и решил, что за день я не управлюсь, тем более что возня с первыми заняла пол дня.
И вот тогда решил сэмулировать движения мышью. Решил что дело выеденного яйца не стоит и начал искать готовый пример и инете. И к своему великому удивлению - не нашел :(
Начал биться сам. В общем на все про все у меня ушел день на вариации, тестирование, поиск в инете + написание этой статьи. Для кого то может это и мало времени что бы разобраться с такой нестандартной ситуацией, а для меня очень и очень много. Поэтому и решил написать эту статью, что бы дорогие коллеги не тратили время на это, а писали бы много хороших программ и желательно фришных, хотя бы для USSR. :O)
я хочу поведать вам об
Приветствую всех любителей Delphi! В этой статье я хочу поведать вам об одной из замечательных, с моей точки зрения, технологии, разработанной Microsoft для облегчения нашей жизни. Теперь любой программист, используя любой современный язык программирования (не исключая и скрип языков!) может с лёгкостью узнать о своём компьютере практически всё. Теперь программисты всех "вероисповеданий" могут определить, какое оборудование установлено на их компьютере, узнать информацию о материнской плате и процессоре, параметры БИОСа, какие процессы запущены в данный момент, какова температура процессора и скорость вращения кулера, какие настройки графической системы, какие.… Одним словом, все о чём вы так долго мечтали, стало доступно благодаря WMI. Звучит заманчиво, не так ли? ;)Естественно, что WMI - это не только набор параметров. А что это такое - читайте ниже.
Представление списков
Строка списка без пробелов представляет собой набор групп чисел, разделенных запятой ",". Группа может состоять из одного числа или диапазона. Последний задается двумя числами, разделенными дефисом "-" (начальное и конечное значение). Опционально после диапазона может стоять значение шага, отделенное знаком плюс "+". По-умолчанию шаг равен 1. Если шаг указан, то конечное значение можно опустить - тогда оно по-умолчанию будет равно максимальному значению в контексте назначения данного списка. Начало диапазона по-умолчанию равно 0.Символ звездочки "*" вместо группы означает весь диапазон возможных значений в данном контексте. Порядок следования групп в строке списка роли не играет.
Пример. Cписок вида: 0-5,8,12,20-30+2
интерпретируется как последовательность: 0,1,2,3,4,5,8,12,20,22,24,26,28,30
Преимущества технологии
Причины перехода от BDE к ADO
Итак, чтобы было понятно что к чему, сначала поясню, зачем же понадобился переход к ADO. Я работаю программистом в компании, которая занимается написанием оболочки для создания геоинформационных систем (ГИС). То есть имеется некая красивая карта и необходимо получение каких-то атрибутивных данных по объектам на этой карте размещенным. При этом атрибутивные таблицы не имеют заранее установленной структуры - только некие предустановленные поля, которых пользователь не видит, но которые используются для связи объектов на карте и записей в базе данных.Итак, для хранения атрибутивной информации был выбран формат MS Access, который имеет то обстоятельство, что все таблицы хранятся в одном файле (в отличие от Paradox и Dbase) и не требует при этом запущенного сервера, как, к примеру, Interbase. Необходима также связь с файлами форматов dbf и db для загрузки/выгрузки данных в/из БД. Для написания программы мы используем Delphi 4, а для подключения к файлам БД использовалась BDE. И все это было отлично, но вот появились два важных обстоятельства:
Плюс ко всему, если вы запускаете эту программу из-под Delphi - ошибка не возникает, а если запускаете ее прямо в Windows - ошибка будет непременно. Я дошел в своих поисках до вызовов прямых вызовов BDE API - вот там-то ошибка и возникает, так что я думаю тут очередная ошибка BDE, хотя я использовал на тот момент самую последнюю версию с сайта Inprise - BDE 5.11.
Так что, господа, если Вы используете нечто подобное в своих программах, то знайте, что под Windows NT 4.0/Windows 2000 Ваши программы работать не будут. Самое интересное, что компоненты из библиотеки VCL, которые используют подобный метод для получения данных (к примеру, TDBRichEdit) тоже не работают!
Приложение со свойствами платформы. Простая платформа.
Если читатель желает начать знакомство с самого начала, нужно найти исчезнувший журнал Программист, в котором были опубликованы статьи по данной платформе:
Впрочем, можно особо не жалеть, если не удастся найти эти статьи, - суть будет здесь изложена в необходимой подробности.
Главная идея
Главная цель платформы состоит в том, чтобы освободить программиста-разработчика от участия в сопровождении многотиражных приложений на уровне программного кода, когда каждому заказчику нужно что-то свое при сохранении общей концепций обработки информации. И другая цель - обеспечить создание много рабочих мест, работающих с общей базой данных, но отличающихся по набору и последовательности выполняемых функций, а также наборами отображаемой информации, в том числе по запросам.
Такие требования характерны, например, для лечебного учреждения, в котором пациент приходит для записи на прием в регистратуру, а потом проходит осмотр и/или лечение у разных врачей: терапевта, окулиста, хирурга и т.д. Все врачи работают с одной и той же информационной единицей, т.е. с амбулаторной картой больного, или с медицинской картой, если это стационар. Но каждый из них имеет свою специфику. Если не принять специальных мер при создании программного обеспечения системы автоматизации лечебного процесса, то придется для каждого врача-специалиста создавать отдельное приложение, причем львиная доля программного кода будет одна и та же во всех этих приложениях.
Платформа в данном случае — это приложение, имеющее в своем составе набор необходимых базовых функций, из которых может быть создан любой алгоритм работы врача. При этом каждая функция пишется программистом один раз, а применяется в любом месте за счет создания соответствующего пункта меню для ее запуска. Впрочем, меню - это всего лишь одно из средств активизации функции. Можно, например, функцию выбирать из специально подготовленного списка. Но рабочего места.
Приведенная концепция при реализации обросла дополнительными примочками, которые стали настолько серьезными, что стали уже играть самостоятельную роль. Одна из таких "примочек" - конструктор баз данных. Описываемая платформа обладает механизмом создания, модификации и удаления таблиц и полей баз данных, доступным на стадии эксплуатации. Развитие этого механизма привело к понятию системной базы данных, т.е. таблиц, скрытых от пользователя, в которых хранится информация о пользовательских таблицах и полях, а также о многочисленных прочих реквизитах, которые оказались полезны при построении интерфейса пользователя и создании главного меню приложения. Дальше больше. Появилась потребность прицепить к любому пользовательскому окну любую таблицу или набор данных запроса, давая при этом возможность отобрать нужные поля для отображения. Названия заголовков колонок таблиц и наборов данных запросов тоже потребовалось сделать редактируемыми при настройке.
Потребовался универсальный механизм вывода отображаемых данных на принтер или в Excel, что является своего рода отчетом. Дальнейшие накрутки пошли при работе с запросами. Составление запроса, как известно, целая наука. Очень утомительно писать запросы повторно, т.е. их нужно где-нибудь хранить. Решено было записывать запросы в ту же самую системную базу данных. Но тогда нельзя гарантировать, что записанный в системную базу запрос останется актуальным при очередной загрузке приложения. Любая таблица за время между запусками могла быть реконструирована так, что запрос, работавший с ним, уже был бы ошибочным. Отсюда появилась задача формирования текста запроса после загрузки информации о пользовательской базе данных. Точнее говоря, текст SQL-запроса формируется в момент использования запроса, автоматически контролируя при этом соответствие структуре базы данных.
Дальнейшее изложение реализованных возможностей в подробностях, пожалуй, уже будет не столь интересно, т. к. основная идея кажется уже очевидной. Конкретный перечень возможностей при этом в каждой предметной области может быть своим и сильно зависит от ряда факторов: уровня подготовки разработчика, его фантазии, наличия команды программистов, способных реализовать большие проекты, т.к. платформа может быть самых разных масштабов. Стоит лишь подчеркнуть, что богатство возможностей платформы будет определяться набором функций.
Добавлю еще, что есть потребность дать пользователю настроить для своих нужд и пользовательский интерфейс: если нужно, что-нибудь добавить в рабочее окно, или убрать какой-либо элемент оттуда, поменять шрифт у контролов, изменить надписи, размеры элементов интерфейса и т.д. Короче говоря, нужно иметь что-нибудь наподобие инспектора свойств из Delphi, но только на русском языке чтобы все показывало.
Вот такая задача.
Перейдем, однако, на сухой язык формального описания идей платформы.
Приведённый код компоненты достаточно прозрачно
Приведённый код компоненты достаточно прозрачно иллюстрирует всё вышесказанное. К сожалению, у меня не хватает времени сделать его самодостаточным для беспроблемной компиляции: в коде встречаются объекты классов (IniFile, ToFile, TrFile, TwFile) и компоненты (TAskDisk), которые являются неотъемлемой составной частью моего инструментального пакета ASK Tools, который будет описан в ближайшее время. Механизм перехвата ИС великолепно работает во всех случаях, когда они генерируются приложением. К сожалению, код, унаследованный из языка «С», не генерирует ИС: когда-то вся обработка ошибочных ситуаций ложилась на плечи прикладного программиста. Таким является весь код из стандартных «С» библиотек, в частности, работа с файлами через дескрипторы и указатели (FILE *). Таким образом, делаем вывод, что для вящей надёжности следует весь унаследованный код, который Вы используете, заключить в оболочку классов, перехватывающих коды возврата всех функций и преобразующих их в ИС. Я не люблю работать с файловыми потоками С++: мне крайне неудобно пользоваться манипуляторами для форматирования выводимых строк. То ли дело форматная строка printf ! Сторонников потоков прошу не спускать на меня всех собак: о вкусах не спорят, к тому же привычка – вторая натура. Поэтому пришлось реализовать иерархию классов TxFile. Основным их достоинством является то, что любую файловую ошибку (в том числе и ошибки чтения/записи) они преобразуют в ИС, которая обрабатывается стандартным способом, в чём можно убедиться, глядя на Рисунок 1. Ну и, кроме того, я кое-чего добавил для более удобного пользования. Хочется отметить, что когда я в родной конторе собрал на сервере локальной сети сообщения с компьютеров всех пользователей и посмотрел статистику, это реально помогло мне найти и обезвредить некоторые глюки. При желании в компоненте можно реализовать опциональную отправку сообщений о сбоях разработчику, что так полюбила теперь Microsoft.Скачать исходные коды (пример на С++): (4K)
Кочетов Андрей
май 2003г.
Специально для
Библиография:
“C++ Builder 5. Developer’s Guide”
J.Hollingworth,D.Butterfield,B.Swart,J.Allsop
Применимость
1. Метод подходит для создания собственных типов XML документов. Когда есть необходимость оперативно разработать свой формат для обмена данными, то проблем возникать не должно. В такой ситуации это может быть оптимальным подходом. Поскольку формат разрабатывается заново, то мы можем учесть все ограничения предложенной реализации и не использовать атрибуты. При этом достаточно спроектировать необходимые нам классы, а вся остальная работа будет проделана автоматически.2. Метод подходит для обработки XML документов, в которых не используются атрибуты. Подобных типов документов не много, но если они подходят, то такой путь их обработки достаточно удобен. Так элемента, а подобное ограничение можно обойти предварительной обработкой загружаемого документа.
Применимость может стать почти универсальной, если доработать код для обработки атрибутов элементов.
Пример просмотра отчета
Ниже приведен код процедуры для просмотра отчета из примера| procedure TFrmMain.btnReportPreviewClick(Sender: TObject); var // Дескриптор окна в котором производится просмотр отчета FWindow: THandle; // Информация об источнике данных. // См. раздел "Получение параметров и свойств источника" lt: PELogOnInfo; begin // В зависимости от флага устанавливаем дескриптор окна. // При нуле, отчет будет показан в независимом внешнем окне. if chkWindow.Checked then FWindow:= 0 else FWindow:= pnlPreview.Handle; // Открываем отчет и получаем дескриптор задачи. FHandleJob:= PEOpenPrintJob(PChar(edtPathReport.Text)); // Получение параметров источника данных отчета. FillChar(lt, SizeOf(PELogOnInfo), 0); lt.StructSize := SizeOf(PELogOnInfo); PEGetNthTableLogOnInfo(FHandleJob, 0, lt); // Устанавливаем новые параметры источника данных отчета. StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) + 'source_db.mdb'); PESetNthTableLogOnInfo(FHandleJob, 0, lt, False); // Настраиваем окно вывода. PEOutputToWindow(FHandleJob, PChar(TForm(Self).Caption), 0, 0, 0, 0, 0, FWindow); // Выводим отчет. PEStartPrintJob(FHandleJob, True); // Закрываем дескриптор задания. PEClosePrintJob(FHandleJob); end; |
Пример реализации методов издателя
Создадим простенькое приложение и проверим существующею связку. Создайте бизнес-объект COM+ инициирующий в любом своем методе метод-событие ReportLog.Пример реализации объекта приведен ниже: unit BsObjectUnit; interface uses ComObj, ActiveX, BsObject_TLB, StdVcl, LogEvent_TLB; type TBusinessObject = class(TAutoObject, IBusinessObject) protected function NewObject(param1: Integer): HResult; safecall; { Protected declarations } end; implementation uses ComServ; function TBusinessObject.NewObject(param1: Integer): HResult; var LogEvent : ISysLogEvent; begin LogEvent := CoSysLogEvent.Create; try LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit','TBusinessObject.NewObject executed!') except LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit','TBusinessObject.NewObject failed!') end; end; initialization TAutoObjectFactory.Create(ComServer, TBusinessObject, Class_BusinessObject, ciMultiInstance, tmApartment); end. После вызова метода NewObject у объекта BusinessObject будет создано событие, которое создаст объект SysLog и запишет и отобразит информацию в диалоговом окне. Подписчиков у созданного объекта EventClass может быть неограниченное количество с самыми разнообразными функциями, от отображения диалогового окна до записи данных в отдельную БД.
Пример реализации Объекта-подписчика
После регистрации компонента EventClass создадим компонент-подписчик.Точно так же, как при создании компонента EventClass создадим библиотеку и объект автоматизации. Немного будет отличаться наполнение реализации методов и метод регистрации.
Создадим интерфейс с методом, аналогичным методу интерфейса ILogEvent – ISysLog (Рисунок 3):
Важно!
Не забудьте подключить в вашу библиотеку типов зарегистрированную в ComponentServices библиотеку с заглушкой EventClass и укажите интерфейс ISysLogEvent в разделе Implements как показано на Рисунок 3а.
Ниже приведен код компоненты подписчика, который будет получать события от издателя. Из реализации бизнес-логики видно, что при возникновении метода-события ReportLog, компонент-подписчик будет выдавать диалоговое окно с информацией для записи в журнал. Если вы замените реализацию этого метода программным кодом записи в файл, вы получите готовый компонент для регистрации ваших событий в бизнес объекте (вывода информации, сообщений об ошибках, отладке и т.д.). unit SysLogUnit; interface uses ComObj, ActiveX, SystemLogger_TLB, StdVcl, LogEvent_TLB, Dialogs; type TSysLog = class(TAutoObject, ISysLog, ISysLogEvent) protected procedure ReportLog(enMsgType: LogMessageTypes; const strUserName, strModuleName, strMsgText: WideString); safecall; { Protected declarations } end; implementation uses ComServ, SysUtils; procedure TSysLog.ReportLog(enMsgType: LogMessageTypes; const strUserName, strModuleName, strMsgText: WideString); begin ShowMessage('MessageType : '+IntToStr(enMsgtype)+#10#13+ 'ModuleName : '+strModuleName+#10#13+ 'UserName : '+strUserName+#10#13+ 'TextMessage : '+strMsgText); end; initialization TAutoObjectFactory.Create(ComServer, TSysLog, Class_SysLog, ciMultiInstance, tmApartment); end. Зарегистрируйте компонент в каталоге COM+ и подпишите его к компоненту EventClass. Как это сделать? Смотрите Рисунок 4.
Рисунок 4
Далее следуйте инструкциям визарда и сделайте выбор как показано на Рисунок 5
Рисунок 5
Итак, у вас на компьютере установлены объекты EventClass и подписчик.
Пример реализации
Эффект использования описанной технологии повышается при увеличении сложности программы, для простых программ она вряд ли целесообразна. В качестве примера я расскажу об одной из своих разработок: Visual2k - Интегрированная среда для программирования микроконтроллерных кукол-роботов. Подробнее о ней и о других программах, использующих "многозвенное программирование" можно узнать на моем web-сайте.Программа Visual2k разработана для томского театра кукол "2+Ку" и проекта "Оживление пространства". Суть проекта состоит в создании кукол-роботов, используемых в рекламных целях, в витринах магазинов и кафе, в качестве гидов на выставках. Куклы могут быть одиночными или работать совместно в автоматическом спектакле. Разработка каждого нового проекта включает в себя такие фазы - художник и сценарист по заказу придумывают сценарий спектакля, затем, вместе с конструкторами обсуждают детали реализации. Когда детали проекта уточнились, инженер-электронщик изготавливает микроконтроллерную аппаратуру, инженер-механик конструирует механику кукол и приводы двигателей, а режиссер - создает с готовыми куклами спектакль. То есть, здесь мы имеем целую цепочку технологов, каждый из которых работает со своей предметной областью.
Visual2k содержит подсистемы, которые позволяют всем технологам работать над проектом в одной и той же интегрированной среде. Задача первого технолога (электронщика) - не только сконструировать аппаратуру, но и начать создание базы проекта. Вот так выглядит подсистема, в которой он работает:
Электронщик вносит в базу проекта имена и типы микроконтроллеров, а также назначает привязку приводов к конкретным выводам микроконтроллеров. Этой информации достаточно, чтобы автоматически сгенерировать программу для микроконтроллеров. Исходный код программы для микроконтроллеров генерируется на языке Си с использованием заранее заготовленной библиотеки драйверов и компилируется Си-компилятором. В зависимости от типа микроконтроллера, генерируется тот или иной Си код.
После этого, файл проекта поступает ко второму технологу (механику). Он работает в этой же подсистеме и создает актеров или их части, назначает действия, которые должны делать куклы-актеры и учитывает специфику приводов, например, создает таблицу скоростей двигателей.
Полученный файл проекта вместе с готовой механикой и электроникой поступает к третьему технологу - режиссеру. Он работает уже с другой предметной областью - сценарием. Поскольку сценарии бывают очень сложными, то режиссер программирует движения кукол на простом алгоритмическом языке, который включает в себя понятия параллельных и последовательных веточек, циклов, условий и команд управления куклами. Вот как выглядит подсистема, в которой работает режиссер:
Здесь стоит отметить, что Visual2k немного напоминает Delphi, с той разницей, что здесь все представлено визуальными компонентами, даже переменные и операторы. Режиссер выстраивает сценарий, выкладывая на рабочую область компоненты-операторы, и назначает их свойства с помощью инспектора объектов. Программа сценария, полученная таким образом, может выполняться либо на персональном компьютере (для сложных говорящих кукол или спектаклей), либо на одном микроконтроллере или сети микроконтроллеров. Исходный вид сценария один и тот же, но генерируется либо текст на языке Object Pascal, который компилируется dcc32, либо текст на языке Cи, объединяемый с частью, заданной электронщиком и компилируемый Cи-компилятором. Поскольку в операторах присваивания и в условиях могут быть выражения, Visual2k включает в себя синтаксический анализатор выражений, обнаруживающий все синтаксические ошибки и заменяющий русские имена переменных и функций на имена, допустимые для языка Pascal. Если кукольный проект будет выполняться под управлением персонального компьютера, то сценарий компилируется в DLL, которая вызывается исполняющим ядром. Такая структура позволяет передавать заказчику только исполняющее ядро и DLL, не раскрывая фирменных секретов спектакля. Параллельные процессы, необходимые для адекватного описания сценария реализуются на базе библиотеки параллельного программирования Gala. Если же сценарий выполняется в микроконтроллере, то используется специально разработанная многозадачная среда с кооперативной мультизадачностью и сценарий зашивается прямо в ПЗУ.
Когда мы получили первый заказ на кукольный спектакль, программы Visual2k еще не было, и я писал сценарий самостоятельно (на Delphi) - режиссер сидел рядом ничего не понимая в том, что я делаю, и только давал советы. Я плохо понимал, чего хочет режиссер, а режиссер вообще не понимал, что я делаю. После создания Visual2k, я занимался только развитием интегрированной среды, добавлял поддержку новых типов микроконтроллеров и новых типов приводов, совершенно не вникая в то, какие делались спектакли. Режиссер очень быстро освоил простой язык описания сценариев и получил полную свободу в реализации своих режиссерских замыслов. Так мне удалось расправиться с целым стадом зайцев - существенно облегчить себе задачу сопровождения программы, освободиться от написания конкретных сценариев, освободить электронщика от написания программ для микроконтроллера и высвободить себе время для других разработок.
The end.
Сергей Гурин
Специально для
Cкачать файлы проекта (80K)
В качестве примера использования класса
В качестве примера использования класса TDataEditor я написал компонент (TGraph), который строит графики функций. А также я сделал ActiveX объект, который демонстрирует возможности компонента TGraph. ActiveX Вы можете увидеть чуть ниже, но сначала несколько слов о методах и свойствах TGraph:TCoord = record X, Y: Double; end; возвращает координаты в масштабе графика. Параметры функции X и Y указывается в масштабе компонента
Прежде чем переходить по ссылке, обратите внимание, придется скачать ActiveX размером 304К.
Принцип работы Инспектора
Инспектор отображается в виде формы, на которую помещены список редактируемых элементов, кнопки переключения страниц свойств, методов и событий и собственно поле Инспектора, разделённое на две части (названия особенностей и их значения).Описание Инспектора (показаны только основные поля, свойства и методы):
TInspector = class private FForm: TInspForm; FullParticuls: TParticulList; CurrParticuls: TParticulList; ActiveIndex: Integer; ActiveEditor: TParticulEditor; procedure ChangeIndex(NewIndex: Integer); procedure Paint; procedure ToolButtonClick(Sender: TObject); public property Visible: Boolean read GetVisible write SetVisible; constructor Create; destructor Destroy; override; procedure Change; procedure Make; end; где
Алгоритм работы Инспектора при щелчке мышью на элементе управления следующий. При щелчке мышью на элементе управления этот элемент добавляется в список Actives (с очисткой его или без в зависимости от состояния клавиши Shift), затем метод MouseDown элемента вызывает метод Change Инспектора. Метод Change производит очистку Инспектора и его полей, устанавливает имена и типы редактируемых элементов в список (верхний в форме Инспектора), формирует полный список особенностей всех элементов из списка Actives (так же как в Delphi, если у разных элементов есть одинаковые особенности и их значения равны, то они отображаются, иначе - нет). Полный список образуется специальным слиянием списков особенностей всех редактируемых элементов (метод класса TParticulList.Comparing). Далее метод Change вызывает метод ToolButtonClick Инспектора, который формирует текущий список CurrParticuls в зависимости от нажатой кнопки "Свойства", "Методы" или "События".
Алгоритм работы Инспектора при щелчке мышью в его рабочем поле (поле отображения особенностей) таков. Метод PaintBoxMouseDown определяет, на какой особенности был сделан щелчок и вызывает метод ChangeIndex с индексом этой особенности. Метод ChangeIndex удаляет старый редактор (оставшийся от прошлого щелчка на рабочей области), в списке CurrParticuls получает особенность, для которой должен быть сформирован новый редактор. Затем с помощью процедур Reference и Executor отыскивает соответственно редактор и обработчик для типа данных TParticul.Data, зарегистрированного ранее, создаёт по этим данным новый редактор и вставляет его в рабочую область Инспектора. В свойство Particul редактора устанавливается найденная особенность.
Алгоритм работы Инспектора при изменении особенности следующий. Редактор, изменивший особенность, записывает его в своё свойство Particul и вызывает метод Инспектора Make. Метод Make вызывает метод SetParticul для редактируемого элемента (если их несколько, то для каждого), в качестве параметра передаёт изменённую особенность из свойства редактора Particul. После этого метод Make заново считывает все особенности редактируемого элемента (или группы) и отрисовывает их в рабочей области Инспектора.
Принудительное скрытие/показ особенностей
Поле TParticul.Visible, как уже упоминалось, отвечает за "видимость" особенности в рабочей области Инспектора. В основном оно используется "внутри" Инспектора и массива особенностей TParticulList; например, при выделении нескольких объектов редактирования, оно скрывает те общие их особенности, поля Code которых не равны (таким же образом поступает Delphi при выделении нескольких компонентов на форме в DesignTime).Однако бывают случаи, когда необходимо скрывать или показывать особенности "вручную". Это те случаи, когда при изменении какой-либо особенности, редактируемый объект в корне меняется и желательно скрыть те свойства, которые при этом значении изменённой особенности не только не нужны, но и мешают сориентироваться в ситуации.
Приведу пример из своего опыта, опять же из области САПР. Допустим, есть схема ТСхема, обладающая свойством База: ТБаза, которое принимает значения бзПневматическая, бзКинематическая, бзЭлектронная. Как известно из автоматики, при замене в схеме, скажем, всех электронных элементов и связей на пневматические, логика работы схемы не меняется. Пусть у нас схема имеет свойство База = бзПневматическая. Тогда в ней важны такие параметры, как давление, поток через проводники, ёмкости резервуаров и другие гидравлические параметры. Мы меняем в Инспекторе свойство База на бзЭлектронная. Тогда станут важны другие параметры, такие как напряжение, сила тока, ёмкости конденсаторов и пр. Как в этом случае быть с давлением и потоком? Можно, конечно, их запретить (TParticul.Enabled := False), однако, при этом загромождается рабочая область Инспектора "лишними" в этом случае особенностями, мешающими нормальной работе пользователя. Поэтому, в этом случае лучше их скрыть вообще: function ТСхема.GetParticuls: TParticulList; var P: TParticul; begin ... P := DoProperty('Давление', dtReal, True, База = бзПневматическая, ДавлениеToStr(FДавление), '', False); Add(P); ... end; Приведу другой пример. Пусть у нас редактируется элемент управления, который при редактировании может менять свой класс, например TComboBox, TColorBox и TShellComboBox (у кого нет последних двух компонентов, поясню: TColorBox - комбобокс выбора цвета, TShellComboBox - выбор папки (как в окнах папок Windows 98 сверху)). Все эти компоненты "комбобоксобразные", у них есть общие свойства, но есть и индивидуальные, например общие: Width, Left, DropDownCount и пр., индивидуальные: TComboBox - Items, CharCase; TColorBox - DefaultColor, Selected; TShellComboBox - Root, UseShellImages. type TMultiControl = class(TExternalControl) private FComboBox: TComboBox; FColorBox: TColorBox; FShellComboBox: TShellComboBox; ... end;
Смена элемента управления будет осуществлена так:
... function TMultiControl.GetParticuls: TParticulList; var P: TParticul; L: TStringList; begin ... {в начале запишем в L три строки - названия классов каждого элемента управления (например, FComboBox.ClassName)} P := DoProperty('Класс', dtEnum, True, True, ExternalObject.ClassName, L.CommaText, False); ... end;
Естественно, до этого в конструкторе свойству ExternalObject должно быть присвоено какое-либо из полей (FComboBox, например) и все поля должны быть проинициализированы.
... procedure TMultiControl.SetParticul(Value: TParticul); var SParent: TWinControl; begin ... if Value.Name = 'Класс' then begin SParent := (ExternalObject as TControl).Parent; (ExternalObject as TControl).Parent := nil; if Value.Code = FComboBox.ClassName then ExternalObject := FComboBox else if Value.Code = FColorBox.ClassName then ExternalObject := FColorBox else ExternalObject := FShellComboBox; (ExternalObject as TControl).Parent := SParent; end; ... end; ...
В таком случае обработка частных особенностей будет происходить таким образом:
... function TMultiControl.GetParticuls: TParticulList; var P: TParticul; begin ... P := DoProperty('Цвет по умолчанию', dtColor, True, ExternalObject is TColorBox, ColorToString(FColorBox.Color), '', False); ... end; Обработка в SetParticul происходит обычным способом, так как "защита от несанкционированных действий" уже предусмотрена в GetParticuls.
В примере Example4 продемонстрирована разработка и использование "мультиэлемента".
Про "софт".
Чтобы не было путаницы в головах, договоримся, что далее под микшером мы будем понимать его "программную ипостась".Для простоты понимания (и дальнейшей работы) представим микшер в виде небольшой иерархической модели.
Как видим, уровни 1 и 2 соответсвуют "железной" модели и имеют прямые аналоги в виде устройств и соединений. Элементы уровня 1 и 2 в современном "железе" размещаются в чипе кодека. Уровни 3 и 4 напрямую не соотносятся с моделью "железа". Они отвечают за характеристики сигнала, который мы слушаем.
Надеюсь, к этому моменту у нас в головах есть сформированная модель, план. Остались технические вопросы multimedia API в части управления микшером.
Как и ранее, я не буду переписывать/переводить MSDN полностью, но наиболее важные моменты, на мой взгляд, отмечу поподробнее. Все функции и структуры для работы с микшером мы разобьем в соответствии с нашей четырехуровневой моделью на несколько блоков.
Уровень 1. Микшер. Структуры и функции, предназначенные для работы с микшером в целом.
Про то, как вычисляется размер зашифрованного текста.
Не всегда можно предположить какой размер будет выходного шифрованного текста, а функции проводящие преобразование требуют что бы память под него была уже выделена (разработчики PGPsdk почему-то это не предусмотрели), и если памяти не хватает - возникает исключение о нехватки памяти. Мною опытным путем была установлена формула для вычисления размера блока: outBufLen := inBufLen*5; if(outBufLen<10000) then outBufLen:=10000; outBufRef := StrAlloc(outBufLen);Временные ключики
В процессе работы программы появляются резервные файлы ключей, имеющие следующий вид - (pub|sec)ring-bak-##.pgp – предусмотрен откат от изменений. В принципе, если Вы правильно используете контекст и правильно его закрываете, этот файл корректно удаляется при освобождение контекста. Но на всякий случай можно его удалять следующим образом (повесить можно на закрытие формы или вызывать принудительно):
| Procedure DeleteBakPGPFiles; Var P : TPreferenceRec; FileSearch : String; SearchRec : TSearchRec; Begin spgpGetPreferences(@P, PGPPrefsFlag_PublicKeyring or PGPPrefsFlag_PrivateKeyring); FileSearch:=P.PublicKeyring; Insert('-bak-*',FileSearch,Pos('.',FileSearch)); FindFirst(FileSearch, faAnyFile, SearchRec); if(SearchRec.Name<>'')then if not(DeleteFile(ExtractFilePath(FileSearch)+SearchRec.Name))then ShowEvent('Not delete file::'+ ExtractFilePath(FileSearch)+SearchRec.Name,0); while(FindNext(SearchRec)=0)do if not(DeleteFile(ExtractFilePath(FileSearch)+SearchRec.Name)) then ShowEvent('Not delete file::'+ ExtractFilePath(FileSearch)+SearchRec.Name,0); FindClose(SearchRec); End; |
Интерфейс пользователя
PGP_sdkUI.dll – это библиотека пользовательских интерфейсов, фирменные штучки от Network Associates, использовав их у Вас будут диалоги такие же как у фирменного пакета PGP. Вам уже не нужно будет строить диалоги самому:
Вывод:
Если Вы читаете эту статью - то Вы наверное уже знаете где в своих приложениях можно применить криптование, PGP это позволит сделать быстро, надежно, открыто и самое главное – переносимо. Но я могу посоветовать еще одно применение - это защита Ваших программ от несанкционированного копирования. Зашить открытый ключ в exe-файл, и рассылать секретный, нужным людям. Вот тут то и появляется поле для простора.
Перечень функций SPGP
| { spgpDecrypt - decryption & signature verification functions } function spgpdecode(BufferIn, BufferOut: PChar; BufferOutLen: LongInt; Pass, SigProps: PChar): LongInt; function spgpdecodefile(FileIn, FileOut, Pass, SigProps: PChar): LongInt; function spgpdetachedsigverify(SigFile, SignedFile, SigProps: PChar):LongInt; { spgpEncrypt - encryption & signing functions } function spgpencode(BufferIn, BufferOut: PChar; BufferOutLen: LongInt; Encrypt, Sign, SignAlg, ConventionalEncrypt, ConventionalAlg, Armor, TextMode, Clear: LongInt; CryptKeyID, SignKeyID, SignKeyPass, ConventionalPass, Comment: PChar): LongInt; function spgpencodefile(FileIn, FileOut: PChar; Encrypt, Sign, SignAlg, ConventionalEncrypt, ConventionalAlg, Armor, TextMode, Clear: LongInt; CryptKeyID, SignKeyID, SignKeyPass, ConventionalPass, Comment: PChar): LongInt; { spgpFeatures - functions to determine PGPsdk version and availability } { of PGPsdk features } function spgpsdkapiversion: Longint; function spgppgpinfo(Info: pPGPInfoRec): LongInt; function countkeyalgs: LongInt; function countcipheralgs: LongInt; { spgpKeyGen - key-generation functions } function spgpkeygenerate(UserID, PassPhrase, NewKeyHexID: PChar; KeyAlg, CipherAlg, Size, ExpiresIn, FastGeneration, FailWithoutEntropy, WinHandle: Longint): LongInt; function spgpsubkeygenerate(MasterKeyHexID, MasterKeyPass, NewSubKeyHexID: PChar; KeyAlg, Size: Longint; ExpiresIn, FastGeneration, FailWithoutEntropy, WinHandle: Longint): LongInt; { spgpKeyIO - Key import/export functions } function spgpkeyexport(pKeyID,BufferOut: PChar;BufferOutLen,ExportPrivate,ExportCompatible: LongInt):LongInt; function spgpkeyexportfile(pKeyID,FileOut: PChar; ExportPrivate,ExportCompatible: LongInt):LongInt; function spgpkeyimport(BufferIn,KeyProps: PChar; KeyPropsLen: LongInt):LongInt; function spgpkeyimportfile(FileIn,KeyProps: PChar; KeyPropsLen: LongInt):LongInt; |
апрель 2002г.
Список используемой литературы и интернет ресурсы
Про "железо".
Я начну издалека, с давних 90-х годов. В те времена звуковые карты (недорогие пищалки) делали на шину ISA по принципу "все-в-одном". В одном чипе были собраны контроллер шины, аудиоконтроллер, ЦАП и АЦП, усилители, синтезатор, интерфейсы джойстика и MIDI и т.д. Получалось интересно: с одной стороны к чипу шли дороги от шины компьютера, а с другой -- к динамикам. Вот такая мельница.Нынче все по-другому. С появлением спецификации AC`97 звуковые платы стали, как минимум, двухкомпонентными: аудиоакселератор (аудиоконтроллер) и кодек. Аудиоакселератор отвечает за взаимодействие с PCI-шиной компьютера и, как правило, имеет блок 3D-эффектов, преобразует данные с помощью встроенного DSP и т.п., то есть реализует аппаратную поддержку всех наворотов ( DirectX, EAX и пр.). Аудиоконтроллер выполняет задачи поскромнее, фактически, только обеспечивает работу с шиной. На выходе аудиоакселератора(аудиоконтроллера) мы имеем ACLink и гоним цифровой звук в формате AC`97. Примеры можно найти на ESS, Cirrus Logic, Creative.
На другом конце ACLink у нас находится кодек, который преобразует цифровой звук в аналоговый и обратно, микширует, фильтрует, усиливает и делает другие вещи. От него фактически зависит качество звука. За примерами можно сходить на ESS, Cirrus Logic или SigmaTel. Кстати, кодеки SigmaTel -- лучшие для своей ценовой категории ( это не реклама :). Для простоты в качестве модели мы возьмем чип CS4235 производства Cirrus Logic. Звуковые платы с ним назывались Crystal и были под шину ISA.
Нас особенно интересует правая часть картинки. Два круга вверху и внизу и есть микшеры, причем верхний микшер работает на вход (I-микшер), а нижний -- на выход (O-микшер).
Полюбовавшись на картину, отметим три вещи:
Первое. Канал от I-микшера к АЦП ( от ЦАП к O-микшеру) только один. С учетом стерео, конечно.
Второе. Мы можем передать данные с I-микшера к O-микшеру напрямую, не оцифровывая звук.
Третье. На картинке с правой стороны есть ряд блоков GAIN. Блоки GAIN -- это аналоговые усилители с цифровым управлением. Они нам интересны тем, что реализуют функции Volume и Mute, то есть регулируют или отключают звук.
И один важный вывод: регулировать громкость можно двумя способами. Первый способ -- "аналоговый", когда мы изменяем усиление через Volume на блоке GAIN. Второй способ -- "цифровой", когда мы изменяем значение каждой выборки уже оцифрованного звука. Если вам важно быстро менять громкость, не влезая в сам сигнал, и вам не требуется большой точности -- первый способ для вас.
Однако, есть некоторые сложности, зависящие от кодека:
Проблемы взаимодействия клиента и сервера
При синхронном взаимодействии клиент вызывает процедуру/функцию/метод сервера, и когда последний возвращает управление, задача уже выполнена. А что, если выполнение длится много дольше, чем клиент может ждать? Это приводит к асинхронной модели взаимодействия клиента и сервера. Клиент дает задание серверу и продолжает заниматься своим делом. Сервер по окончанию работы должен известить клиента каким-либо образом.Самый древний известный способ - выставление программного флага - является и самым плохим решением, поскольку заставляет клиента периодически проверять этот флаг. Как бы сделать так, чтобы клиент получал извещения самым естественным для него способом и не тратил процессорное время на тупое ожидание и даже на проверку?
Здесь следует уточнить, что описываемые проблемы наиболее актуальны при взаимодействии клиента и сервера, выполняющихся в разных потоках или в разных процессах. Современная наука предоставляет следующий выбор средств нотификации, не привязанных к высокоуровневым технологиям:
Process: Explorer.exe. Modules Information.
| Usage Image Addr Base Addr Size Module 1 00B10000 10000000 32768 F:\PROGRA~1\Adobe\ACROBA~1\Reader\ActiveX\AcroIEHelper.ocx 1 00F00000 10000000 24576 F:\PROGRA~1\Logitech\MOUSEW~1\SYSTEM\LGMOUSHK.dll Fixed 01000000 1011712 F:\WINDOWS\Explorer.EXE 2 01750000 10000000 552960 F:\WINDOWS\System32\NOVNPNT.DLL 2 017E0000 10000000 221184 F:\WINDOWS\System32\MAPBASE.dll 1 018E0000 6A400000 65536 F:\WINDOWS\System32\NLS\ENGLISH\NWSHLXNR.DLL 2 01A20000 10000000 184320 F:\WINDOWS\System32\NWSHLXNT.dll 1 01D10000 6A400000 225280 F:\WINDOWS\System32\NLS\ENGLISH\NOVNPNTR.DLL 1 01ED0000 10000000 114688 F:\PROGRA~1\Common Files\Adobe\Shell\PSICON.DLL 1 02210000 10000000 53248 F:\PROGRA~1\KASPER~1\ANTIVI~1\avpshlex.dll 1 02230000 01500000 147456 F:\Program Files\WinRAR\rarext.dll 1 02A70000 10000000 217088 F:\Program Files\7-ZIP\7-zipn.dll 1 0FFD0000 139264 F:\WINDOWS\System32\rsaenh.dll 1 10000000 16384 F:\Program Files\Punto Switcher\correct.dll 4 1F7B0000 200704 F:\WINDOWS\System32\ODBC32.dll 1 1F850000 90112 F:\WINDOWS\System32\odbcint.dll 1 32270000 28672 F:\Program Files\Miranda\Plugins\BOSSKEY.DLL 1 32520000 73728 F:\Program Files\Microsoft Office\Office10\msohev.dll 8 50D00000 86016 F:\WINDOWS\System32\CLNWIN32.DLL 6 50D20000 163840 F:\WINDOWS\System32\CALWIN32.DLL 6 50D50000 282624 F:\WINDOWS\System32\NETWIN32.DLL 6 50DA0000 45056 F:\WINDOWS\System32\CLXWIN32.DLL 6 50DB0000 167936 F:\WINDOWS\System32\NCPWIN32.dll 16 50DF0000 131072 F:\WINDOWS\System32\LOCWIN32.DLL Fixed 5AD70000 212992 F:\WINDOWS\System32\UxTheme.dll 1 5B630000 458752 F:\WINDOWS\System32\themeui.dll 1 68880000 258048 F:\WINDOWS\System32\hnetcfg.dll 1 6A400000 110592 F:\WINDOWS\System32\NLS\ENGLISH\MAPBASER.DLL 2 6C1B0000 274432 F:\WINDOWS\System32\DUSER.dll 16 71AA0000 32768 F:\WINDOWS\system32\WS2HELP.dll 26 71AB0000 86016 F:\WINDOWS\system32\WS2_32.dll 2 71AD0000 32768 F:\WINDOWS\System32\WSOCK32.dll 12 71B20000 69632 F:\WINDOWS\system32\MPR.dll 4 71BF0000 69632 F:\WINDOWS\System32\SAMLIB.dll 1 71C10000 53248 F:\WINDOWS\System32\ntlanman.dll 31 71C20000 323584 F:\WINDOWS\System32\NETAPI32.dll 2 71C80000 24576 F:\WINDOWS\System32\NETRAP.dll 1 71C90000 245760 F:\WINDOWS\System32\NETUI1.dll 2 71CD0000 90112 F:\WINDOWS\System32\NETUI0.dll 1 71D40000 110592 F:\WINDOWS\System32\ACTXPRXY.DLL 2 72410000 102400 F:\WINDOWS\System32\mydocs.dll 1 72430000 73728 F:\WINDOWS\System32\browselc.dll 2 72D10000 32768 F:\WINDOWS\System32\msacm32.drv 4 72D20000 36864 F:\WINDOWS\System32\wdmaud.drv 2 73000000 143360 F:\WINDOWS\System32\WINSPOOL.DRV 1 73380000 331776 F:\WINDOWS\System32\zipfldr.dll 1 74770000 585728 F:\WINDOWS\System32\MLANG.dll 2 74AD0000 28672 F:\WINDOWS\System32\POWRPROF.dll 1 74AE0000 28672 F:\WINDOWS\System32\CFGMGR32.dll 1 74AF0000 36864 F:\WINDOWS\System32\BatMeter.dll 1 74B00000 131072 F:\WINDOWS\System32\stobject.dll 1 74B30000 266240 F:\WINDOWS\System32\webcheck.dll 1 74B80000 532480 F:\WINDOWS\System32\printui.dll 1 74ED0000 61440 F:\WINDOWS\System32\wbem\wbemsvc.dll 1 74EF0000 40960 F:\WINDOWS\System32\wbem\wbemprox.dll 1 74FC0000 65536 F:\WINDOWS\System32\CLUSAPI.dll 2 75290000 229376 F:\WINDOWS\System32\wbem\wbemcomn.dll 1 755F0000 593920 F:\WINDOWS\System32\netcfgx.dll 1 75690000 598016 F:\WINDOWS\System32\wbem\fastprox.dll 4 75970000 987136 F:\WINDOWS\System32\MSGINA.dll 10 75A70000 667648 F:\WINDOWS\system32\USERENV.dll 2 75CF0000 1638400 F:\WINDOWS\system32\NETSHELL.dll 1 75E90000 659456 F:\WINDOWS\System32\SXS.DLL 2 75F40000 118784 F:\WINDOWS\system32\appHelp.dll 1 75F60000 24576 F:\WINDOWS\System32\drprov.dll 1 75F70000 36864 F:\WINDOWS\System32\davclnt.dll Fixed 75F80000 1032192 F:\WINDOWS\System32\BROWSEUI.dll 1 760F0000 491520 F:\WINDOWS\System32\urlmon.dll 1 76170000 557056 F:\WINDOWS\System32\shdoclc.dll 2 76200000 618496 F:\WINDOWS\system32\WININET.dll 5 762A0000 61440 F:\WINDOWS\system32\MSASN1.dll 5 762C0000 565248 F:\WINDOWS\system32\CRYPT32.dll 11 76360000 61440 F:\WINDOWS\System32\WINSTA.dll 2 76380000 20480 F:\WINDOWS\System32\MSIMG32.dll 5 763B0000 282624 F:\WINDOWS\system32\comdlg32.dll 2 76400000 2076672 F:\WINDOWS\System32\msi.dll 5 76600000 110592 F:\WINDOWS\System32\CSCDLL.dll 3 76620000 319488 F:\WINDOWS\System32\cscui.dll 7 76670000 933888 F:\WINDOWS\System32\SETUPAPI.dll 1 76980000 28672 F:\WINDOWS\System32\LINKINFO.dll 5 76990000 147456 F:\WINDOWS\System32\ntshrui.dll Fixed 769C0000 1347584 F:\WINDOWS\System32\SHDOCVW.dll 8 76B20000 86016 F:\WINDOWS\System32\ATL.DLL 17 76B40000 180224 F:\WINDOWS\System32\WINMM.dll 2 76C00000 184320 F:\WINDOWS\system32\credui.dll 1 76C30000 176128 F:\WINDOWS\System32\WINTRUST.dll 1 76C90000 139264 F:\WINDOWS\system32\IMAGEHLP.dll 2 76D30000 16384 F:\WINDOWS\system32\WMI.dll 2 76D40000 90112 F:\WINDOWS\system32\MPRAPI.dll 7 76D60000 86016 F:\WINDOWS\system32\iphlpapi.dll 3 76D80000 106496 F:\WINDOWS\system32\DHCPCSVC.DLL 2 76DA0000 196608 F:\WINDOWS\system32\WZCSvc.DLL 2 76DE0000 155648 F:\WINDOWS\system32\netman.dll 4 76E10000 147456 F:\WINDOWS\system32\adsldpc.dll 3 76E40000 192512 F:\WINDOWS\system32\ACTIVEDS.dll 9 76E80000 53248 F:\WINDOWS\system32\rtutils.dll 4 76E90000 69632 F:\WINDOWS\system32\rasman.dll 4 76EB0000 172032 F:\WINDOWS\system32\TAPI32.dll 5 76EE0000 225280 F:\WINDOWS\system32\RASAPI32.dll 3 76F20000 151552 F:\WINDOWS\system32\DNSAPI.dll 3 76F50000 32768 F:\WINDOWS\System32\WTSAPI32.dll 3 76F60000 180224 F:\WINDOWS\system32\WLDAP32.dll 9 76F90000 65536 F:\WINDOWS\System32\Secur32.dll 2 76FD0000 491520 F:\WINDOWS\System32\CLBCATQ.DLL 2 77050000 806912 F:\WINDOWS\System32\COMRes.dll Fixed 77120000 569344 F:\WINDOWS\system32\OLEAUT32.dll Fixed 771B0000 1155072 F:\WINDOWS\system32\ole32.dll Fixed 772D0000 405504 F:\WINDOWS\system32\SHLWAPI.dll 14 77340000 569344 F:\WINDOWS\system32\comctl32.dll Fixed 773D0000 8339456 F:\WINDOWS\system32\SHELL32.dll 1 77BD0000 28672 F:\WINDOWS\System32\midimap.dll 2 77BE0000 81920 F:\WINDOWS\System32\MSACM32.dll 10 77C00000 28672 F:\WINDOWS\system32\VERSION.dll Fixed 77C10000 339968 F:\WINDOWS\system32\msvcrt.dll Fixed 77C70000 262144 F:\WINDOWS\system32\GDI32.dll Fixed 77CC0000 479232 F:\WINDOWS\system32\RPCRT4.dll Fixed 77D40000 577536 F:\WINDOWS\system32\USER32.dll Fixed 77DD0000 569344 F:\WINDOWS\system32\ADVAPI32.dll Fixed 77E60000 937984 F:\WINDOWS\system32\kernel32.dll Fixed 77F50000 692224 F:\WINDOWS\System32\ntdll.dll |
Примечание:
Продолжение
| Раздел Поземелье Магов |
§3 Организация данных в виде связанных указателями структур.
Актуальность задачи распределения и перераспределения памяти сохранилась, когда появились 32-разрядные ОС и СРП, позволяющие адресоваться из одного массива данных к оперативной памяти размером до 4 Гбайт, так как редко встречаются алгоритмы, обходящиеся одним массивом, как правило, их бывает несколько и в случае, если в алгоритме используется память полиномиального размера [2], перед разработчиком встает вопрос о способах организации данных. Прежде чем подавать на вход алгоритма исходные данные, надо договориться о том как они представляются в "понятном для компьютера виде". До появления в СРП Delphi 4, вышедшем в 1998 г., новой структуры данных, под названием динамический массив (ДМ), который позволяет работать с массивами данных, резервируя место в памяти по мере необходимости, при программировании на Pascal обходились линейными списками [1]. При программировании на Delphi для организации списков можно воспользоваться классом (объектом) TList из модуля classes, но требуется дополнительное программирование объектов наследников от TList. Возможны две нотации: 1) либо наследовать от TList
TDataListI = class (TList) // (1*) protected procedure Put(Index: Integer; Item: TData); function Get (Index: Integer): TData; public procedure Add (Obj: TData); property Items[Index: Integer]: TData read Get write Put; default; end; 2) либо вставлять класс TList в класс контейнер (оболочку)
TDataListW = class(TObject) // (2*) private FList: TList; function Get(Index: Integer): TData; procedure Put(Index: Integer; Item: TData); function GetCount: Integer; public constructor Create; destructor Destroy; override; function Add(Item: TData): Integer; function Equals(List: TDataListW): Boolean; property Count: Integer read GetCount; property Items[Index: Integer]: TData read Get write Put; default; end; Тип TData, как правило, является классом, но может быть любым типом. Если тип элемента не класс сложнее освободить память, т.к. операции освобождения ложатся не на функцию Destroy, принадлежащую классу, а на дополнительные модули или операторы в Ваших модулях. Как видно из описания классов унификация внутри модуля относительно типа элементов (записи, класса и т. п.), из которых состоят списки, существует только для классов, Т.к. только классы "знают" как себя освобождать. Для реализации этой идеи нужно переписать класс TDataListW, например, следующим образом:
TDataListС = class // (3*) private LType: TClass; FList: TList; function Get (Index: Integer): TObject; procedure Put (Index: Integer; Item: TObject); function GetCount: Integer; public constructor Create (CType: TClass); destructor Destroy; override; function Add (Item: TObject): Integer; function Equals(List: TDataListС): Boolean; property Count: Integer read GetCount; property Items [Index: Integer]: TObject read Get write Put; default; end; Идентификаторы методов в переводе отражают их предназначение. Тексты не приводятся в силу их тривиальности. В итоге, применяя методы Create и Add, можно создавать списки и добавлять в них новые элементы. Обращаться к элементам списков можно при помощи идентификатора Items или как к обычному элементу массива, т. к. свойство Items определено как default. Кроме того, в Delphi определены классы: TClassList и TObjectList (из модуля contnrs) наследуемые от Tlist и похожие на класс TDataListС; TStack, TObjectStack, TQueue, TОbjectQueue наследуемые от TOrderedList, реализующие различные виды линейных списков [1]; TCollection (из модуля classes) наследуемые от TPersistent, в котором реализована возможность синхронизации доступа к элементам благодаря методам BeginUpdate, EndUpdate; TStrings (из модуля classes) наследуемые от TPersistent, абстрактный базовый класс для манипуляции со строками; TStringList (из модуля classes) наследуемые от TStrings, управляющий списками строк и присоединённых к ним объектов с замещенными абстрактными методами из TStrings. Как видите, многообразие довольно широкое. Могут быть и проблемы. У всего 16 байт, но при интенсивной работе со списками это приводило к нехватке оперативной памяти. Поэтому, по-видимому, имеет право на существование подход, когда разработчик не использует чужих классов, а всё пишет сам. Это не сложно. Сначала создается запись, которая будет являться элементом списка.
PItem_Tree = ^TItem_Tree; TItem_Tree = record { Рабочая часть записи } ... {-------------------------------------------------} { Часть записи для организации списка } Next: PItem_Tree; end; Затем пишется класс, реализующий список.
TRecList = class // (4*) private Head, Last: PItem_Tree; BeforeSet: PItem_Tree; IndexBeforeSet: integer; BeforeGet: PItem_Tree; IndexBeforeGet: integer; FCount: integer; RetCode: byte; function GetItem(Index: integer): TItem_Tree; procedure SetItem(Index: integer; Rec: TItem_Tree); function Empty: boolean; function GetNodeSet(i:integer): PItem_Tree; function GetNodeGet(i:integer): PItem_Tree; protected function GetCount: integer; public constructor Create; destructor Destroy; override; procedure Clear; function Add(Rec: TItem_Tree): integer; virtual; function AddBegin(Rec: TItem_Tree): integer; virtual; procedure Assign(var Output: TRecList); procedure Insert(Index: integer; const Rec: TItem_Tree); virtual; procedure DeleteFromListCheckedFlagItog; procedure CopyRec(const Input: TItem_Tree; var Output: TItem_Tree); property Items[i: integer]:TItem_Tree read GetItem write SetItem;default; property Count: integer read GetCount; end; function TRecList.Empty:boolean; begin if Head <> nil then begin RetCode:=Succes; if Head^.Next=nil then Empty:=TRUE else Empty:=FALSE end else begin RetCode:=NotFill; Empty:=TRUE; end; end; procedure TRecList.CopyRec(const Input:TItem_Tree; var Output:TItem_Tree); begin with OUTPUT do begin { Присвоение рабочей части записи } ... { Часть записи для организации списка } Next:=nil; end; end; constructor TRecList.Create; begin inherited Create; Head:=nil; Last:=Head; Before:=Head; IndexBefore:=0; BeforeSet:=Head; IndexBeforeSet:=0; BeforeGet:=Head; IndexBeforeGet:=0; FCount:=0; end; destructor TRecList.Destroy; begin Clear; inherited Destroy; end; procedure TRecList.Clear; var P,P1:PItem_Tree; begin if Head<>nil then begin if Empty and (RetCode=Succes) then begin Dispose(Head); Head:=nil; RetCode:=Succes; Exit; end; P:=Head; while P<>nil do begin P1:=P^.Next; Dispose(P); P:=P1; end; RetCode:=Succes; Head :=nil; Last :=nil; Before :=nil; IndexBefore:=0; BeforeSet :=nil; IndexBeforeSet:=0; BeforeGet :=nil; IndexBeforeGet:=0; FCount:=0; end else RetCode:=NotFill; end; function TRecList.GetNodeSet(i:integer): PItem_Tree; var j: integer; P: PItem_Tree; begin RetCode:=Succes; if (i-1=IndexBeforeSet) and (BeforeSet <> nil) then begin P:=BeforeSet^.Next; BeforeSet:=P; IndexBeforeSet:=i; GetNodeSet:=P; end else begin P:=Head; j:=0; while P<>nil do begin if i=j then break; P:=P^.Next; Inc(j); end; BeforeSet:=P; IndexBeforeSet:=i; GetNodeSet:=P; end; end; function TRecList.GetNodeGet(i: integer): PItem_Tree; var j: integer; P: PItem_Tree; begin RetCode:=Succes; if (i-1=IndexBeforeGet) and (BeforeGet <> nil) then begin P:=BeforeGet^.Next; BeforeGet:=P; IndexBeforeGet:=i; GetNodeGet:=P; end else begin P:=Head; j:=0; while P<>nil do begin if i=j then break; P:=P^.Next; Inc(j); end; BeforeGet:=P; IndexBeforeGet:=i; GetNodeGet:=P; end; end; procedure TRecList.SetItem(Index: integer; Rec: TItem_Tree); var P, P1: PItem_Tree; begin if Index>FCount then begin RetCode:=ErrIndex; Exit; end; P:=GetNodeSet(Index); if RetCode=Succes then begin P1:=P^.Next; CopyRec(Rec, P^); P^.Next:=P1; end; end; function TRecList.GetItem(Index: integer): TItem_Tree; var P:PItem_Tree; begin if Index>FCount then begin RetCode:=ErrIndex; Exit; end; P:=GetNodeGet(Index); if RetCode=Succes then if P<>nil then CopyRec(P^, Result); end; function TRecList.Add(Rec: TItem_Tree): integer; begin if Head=nil then begin New(Head); if Head<>nil then begin CopyRec(Rec, Head^); Last:=Head; FCount:=1; Result:=1; end else Result:=-1; end else begin New(Last^.Next); Last:=Last^.Next; CopyRec(Rec, Last^); Inc(FCount); Result:=FCount; end; end; function TRecList.Addbegin(Rec: TItem_Tree): integer; var P: PItem_Tree; begin if Head=nil then begin New(Head); if Head<>nil then begin CopyRec(Rec, Head^); Last:=Head; FCount:=1; Result:=1; end else Result:=-1; end else begin New(P); P^.Next:=Head; Head:=P; P:=P^.Next; BeforeSet:=Head; IndexBeforeSet:=0; BeforeGet:=Head; IndexBeforeGet:=0; CopyRec(Rec, Head^); Head^.Next:=P; Inc(FCount); Result:=FCount; end; end; procedure TRecList.Assign(var Output: TRecList); begin output.Clear; output.Head:=Head; output.Last:=Last; output.BeforeSet:=BeforeSet; output.IndexBeforeSet:=IndexBeforeSet; output.BeforeGet:=BeforeGet; output.IndexBeforeGet:=IndexBeforeGet; output.FCount:=FCount; inherited Destroy; end; procedure TRecList.Insert(Index: integer; const Rec: TItem_Tree); var P,P1,P2:PItem_Tree; i: integer; begin New(P); Inc(FCount); CopyRec(Rec, P^); if Head=nil then Head:=P else { Если список не пуст } begin P1:=Head; P2:=Head; i:=0; while (P2<>nil) and (ido begin P1:=P2; P2:=P2^.Next; Inc(i) end; { Пройден весь список-элемент в конец } if P2=nil then P1^.Next:=P else begin P^.Next:=P2; { В начало списка } if P2=Head then Head:=P else { Внутрь списка } P1^.Next:=P end; end; end; function TRecList.GetCount: integer; begin GetCount:=FCount; end; procedure TRecList.DeleteFromListCheckedFlagItog; var P, P1: PItem_Tree; begin P:=Head; while P<>nil do if not P^.FlagItog then begin { Удаление из начала списка } if P=Head then begin Head:=Head^.Next; Dispose(P); Dec(FCount); P:=Head; end else begin { Удаление из середины списка } P1^.Next:=P^.Next; Dispose(P); Dec(FCount); P:=P1^.Next; end; end else begin { Переход на следующий элемент списка} P1:=P; P:=P^.Next; end; end; Метод Empty предназначен для проверки списка на наличие элементов, используется в других методах класса. CopyRec используется для заполнения элементов списка. Create и Destroy для создания и уничтожения списка соответственно. Clear - удаляет все элементы из списка. Методы GetNodeSet, GetNodeGet совместно с полями BeforeSet, IndexBeforeSet, BeforeGet, IndexBeforeGet используются как внутренние и обеспечивают простенькую оптимизацию без дополнительных связей, основанную на том, что при чтении и записи элементов подряд достаточно хранить индекс предыдущего элемента для проверки и ссылку на предыдущий элемент для выполнения действий. Этот способ оптимизации для однонаправленного списка сказывается, естественно, только для больших списков (сотни тысяч элементов). Методы SetItem и GetItem обслуживают доступ к элементам через свойство Items. Добавление элементов в конец, начало и указанное место списка обслуживается методами Add, AddBegin, Insert. Assign при помощи полей Head (указатель на первый элемент) и Last (указатель на последний элемент) поддерживает копирование из списка в список. DeleteFromListCheckedFlagItog тоже метод с "хитринкой". Если Вы, работая с большим списком, попытаетесь поэлементно удалять из него, это займет много времени. Однако, можно просто пометить какое-то поле в элементе вместо удаления, а затем, просматривая список один раз, удалить все помеченные элементы. Попутно отметим, что в объектах аналогичных выше приведенным возможно выполнять сжатие данных (хранить в элементах списка типы данных меньшего размера, чем данные, с которыми производятся какие-то действия). При программировании на Delphi для сжатия узла списка можно воспользоваться классом (объектом) TBits из модуля classes. В случае, если поля узла списка имеют тип массива байт, слов и т. п., можно при сохранении структуры в узле списка производить операции сжатия данных, например, как в функции приведённой ниже.
function ByteTo2Bit(B: array of Byte; var Bit: TBits): boolean; var i, j: integer; begin ByteTo2Bit:=True; Bit:=TBits.Create; Bit.Size:=Length(B)*2; for i:=Low(B) to High(B) do begin j:=(i-Low(B))*2; if B[i]=2 then Bit.Bits[j]:=True else if B[i]=1 then Bit.Bits[j+1]:=True; end; end; А при извлечении данных из узла списка для работы, использовать функцию Bit2ToByte.
function Bit2ToByte(Bit: TBits; var B: array of Byte): Boolean; var i, j: integer; begin Bit2ToByte:=True; if Length(B)*2 < Bit.Size then begin Bit2ToByte:=False; Exit; end; i:=0; while i
| Тип объекта | Размер списка | Время счёта в [мин:]сек | Затраченная ОП в Кбайт |
| Без сжатия | 50000 100000 150000 200000 |
2 4 12 25 |
171000 343000 470000 472884 |
| Со сжатием | 10000 50000 100000 150000 500000 |
21 1:48 3:37 5:47 18:41 |
13560 62404 123472 184528 481372 |
Если вы честно прочитали всё,
Если вы честно прочитали всё, что написано выше, и не поленились посмотреть в MSDN'е описание упомянутых в тексте функций, вы уже можете самостоятельно написать программу, подобную Canvas2. Правда, новичков нередко ставит в тупик задача создания "резиновой" линии, особенно кривой, которую потом можно изменять. Однако эта задача не требует ни каких-либо специальных знаний, ни особого напряжения интеллекта. Достаточно просто набраться терпения, просчитать все возможные состояния процесса и описать реакцию на все эти состояния в программе.Начиная с этого момента я предполагаю, что вы уже успели попробовать Canvas2 и поэтому хорошо представляете процесс рисования кривых с её помощью.
Итак, у нас есть два основных состояния: когда рисование кривой ещё не начато, и нажатие левой кнопки мыши приведёт к появлению "резиновой" прямой, которая затем станет основой для кривой, и когда кривая уже нарисована, но ещё не "впечатана" в рисунок, т.е. её крайние и промежуточные точки можно передвигать. Переменная TCurveForm.NewLine типа Boolean указывает, в каком из двух состояний находится программа: в первом (True) или во втором (False).
Когда пользователь схватил точку и тащит её, возможно шесть вариантов: схвачена одна из четырёх контрольных точек редактируемой кривой, рисуется "резиновая" прямая или при редактировании кривой пользователь промахнулся и не схватил ни одной из контрольных точек. Для описания того, какая точка сейчас перемещается пользователем, объявлена переменная TCurveForm.DragPoint специально созданного типа TDragPoint. Эта переменная может иметь следующие значения:
Для хранения координат кривой используется массив TCurveForm.Curve. Его нулевой элемент хранит начало прямой, третий - её конец, а первый и второй - промежуточные точки. В режиме "резиновой" прямой первый и второй элементы не используются, поэтому они могут иметь произвольные значения.
Процедура OnPaint должна учитывать состояние программы: до редактирования кривой ещё не дошло (NewLine=True), нужно проверить, не перемещает ли пользователь концевую точку прямой, и если да, нарисовать эту прямую. Если редоктирование кривой уже начато, надо отобразить кривую и дополнительные элементы для редактирования (касательные и маркеры контрольных точек).
Когда пользователь нажимает кнопку мыши, программа должна проверить, в каком состоянии находится программа. Если редактирование кривой ещё не начато, это нажатие означает начало рисования "резиновой" прямой. Для перехода в этот режим значение DragPoint устанавливается в dpFirst. Если редактирование кривой уже начато, необходимо проверить, попадает ли позиция курсора мыши в окрестность какой-либо контрольной точки, и на основании результатов проверки присвоить соответствующее значение переменной DragPoint. Для проверки определена функция PtNearPt. Строго говоря, необходимо также запоминать, насколько отстоят координаты курсора мыши от координат контрольной точки, чтобы при первом перемещении не было скачка. Но так как окрестность точки очень мала, этот прыжок практически незаметен, и в данном случае этим можно пренебречь, чтобы не усложнять программу.
При перемещении мыши нужно проверить, нажата ли левая кнопка и перемещает ли пользователь какую-либо точку. Если да, требуется обновить координаты этой точки и перерисовать окно.
При отпускании пользователем кнопки мыши какие-либо действия требуются, только если до этого был установлен режим "резиновой" прямой. В этом случае нужно вычислить координаты промежуточных точек (они выбираются на прямой) и перейти в режим редактирования кривой.
Нажатие кнопки "Завершить" осуществляет выход из режима редактирования кривой. Кривая переносится на растр TCurveForm.Back, а значение NewLine снова устанавливается в True.
Функция рисования кривой достаточно проста. Сначала рассчитываются координаты опорных точек. Если включен режим рисования по опорным точкам, координаты этих точек хранятся в первом и втором элементах массива Curve. Если включен режим рисования по промежуточным точкам, координаты опорных точек вычисляются по формулам (2). Затем на основе кривой создаётся траектория, затем она преобразуется в ломаную, и координаты её узлов записываются в массив PtBuf. В массив TpBuf записываются типы точек, но в данном случае они нам неинтересны: траектория содержит только один контур, состоящий только из отрезков прямых. Далее последовательно вызывается функция LineDDA для каждого из отрезков. При этом вычисляется длина отрезка и смещения координат DX и DY. Это нужно для построения поперечных линий. Как показала практика, начало и конец отрезка иногда совпадают, и его длина равна нулю, поэтому нужна дополнительная проверка, позволяющая избежать деления на ноль.
Функция LineDDA передаёт в вызываемую ею LineDrawFunc один дополнительный параметр, который использован для передачи объекта холста (Canvas), на котором следует рисовать отрезок. Этот параметр в соответствии с описанием функции является целым числом, но контроль типов здесь отсутствует, поэтому можно использовать любую 32-разрадную величину. Так как все переменные объектов в Delphi являются 32-разрядными указателями, объект TCanvas может быть передан в качестве этого параметра. Функция LineDDA не считает точки, поэтому это приходится делать самостоятельно с помощью переменной TCurveForm.Counter. Так как значение этой переменной между рисованием отдельных ломаных не меняется, кривая имеет целостный вид.
Функция LineDrawFunc достаточно проста для понимания. В некотором комментарии нуждается только выбор толщины пера при рисовании стилем "плакатное перо". Предположим, некоторая точка прямой имеет координаты (X,Y), а соседняя с ней - координаты (X+1,Y-1). Тогда при проведении через эти точки наклонной линии одинарной ширины между ними останутся незаполненные точки, как на шахматной доске. Поэтому потребовалось увеличить толщину пера.
Надеюсь, изложенные здесь материал оказался вам полезным
С пожеланиями творческих успехов
Специально для
Скачать (170K)
| Для данного материала нет комментариев. |
Программируем
Первым надо "запустить машину" CR, посредством вызова функции PEOpenEngine для инициализации механизма отчетов. Надо заметить, что вызов данной функции справедлив только для одного потока.Теперь можно и начать подготовку отчета для вывода. Вызов PEOpenPrintJob дает нам дескриптор задачи (отчета), который необходимо передавать в другие функции.
| Синтаксис функции PEOpenPrintJob(PathToReport: PChar): SmallInt; где, PathToReport - путь к файлу отчета. Результат функции - дескриптор полученной задачи. Пример: FHandleJob:= PEOpenPrintJob(PChar(edtPathReport.Text)); |
Получив дескриптор, мы можем, манипулировать отчетом как нам будет угодно. Получать информацию о параметрах, об источнике данных, управлять разделами отчета и формулами.
Далее необходимо сказать системе, куда выводить отчет: в окно предварительного просмотра (…ToWindow) или на принтер (…ToPrinter).
| Синтаксис функций: PEOutputToWindow(printJob : Smallint; title: PChar; left: Integer; top: Integer; width: Integer; height: Integer; style: DWord; parentWindow : HWnd): Bool; PEOutputToPrinter(printJob: Word; nCopies: Integer)): Bool; где, printJob - дескриптор задачи title - заголовок окна left, top, width, height - координаты окна style - стиль окна (типа WS_VSCROLL, WS_VISIBLE и т.д.) parentWindow - дескриптор окна в котором будет окно отчета. nCopies - количество копий. Пример: Result:= PEOutputToWindow(FHandleJob, PChar(TForm(Self).Caption), 0, 0, 0, 0, 0, FWindow); |
Подготовив механизм вывода отправляем отчет для вывода функцией PEStartPrintJob.
| Синтаксис функции: function PEStartPrintJob(printJob: Word; waitUntilDone: Bool): Bool; где, printJob - дескриптор задачи. WaitUntilDone - зарезервирован. Всегда должен быть True. Пример: PEStartPrintJob(FHandleJob, True); |
После отправки отчета, если не надо производить с ним операций, закрываем задание функцией PEClosePrintJob.
| Синтаксис функции: function PEClosePrintJob (printJob: Word): Bool; где, printJob - дескриптор задачи. Пример: PEClosePrintJob(FHandleJob); |
Между вызовами функций PEOpenPrintJob и PEClosePrintJob может стоять сколько угодно вызовов функций PEOutputTo…, PEStartPrintJob.
В итоге получается схема вызовов:
| PEOpenEngine | ||
| | | ||
| PEOpenPrintJob | ||
| | | ||
| PEOutputToWindow | ||
| | | ||
| PEStartPrintJob | ||
| | | ||
| PEClosePrintJob | ||
| | | ||
| PECloseEngine | ||
Производительность
Код загрузки XML документа в объект дает вполне приемлемую производительность. Тестирование дало следующие результаты.Документ: формат ONIX XML размером 10 мб.
Системная конфигурация: Celeron 450 / 256 / Windows 2000prof
| парсер | приблизительное время загрузки |
| MS XML Parser 2.6 синхронная загрузка без проверки состоятельности | ~6 сек |
| MS XML Parser 2.6 синхронная загрузка с проверкой состоятельности | ~11 сек |
| Компонент TglXMLSerializer | 8,5 сек |
Проверка состоятельности определяется тем, что при загрузке данные загружаются в свойства объекта. Если одноименное элементу XML документа свойство не найдено, то генерируется исключение. Так как свойства объекта типизированы и при загрузке происходит преобразование текстовых значений, то ошибки, здесь возникающие, говорят о нарушении состоятельности документа. Таким образом, интерфейс нашего объекта играет роль XML схемы, что очень удобно. Более того, эти проверки могут быть расширены дополнительным кодом в обработчиках свойств объекта.
| Раздел Подземелье Магов | рь, дата публикации 14 февраля 2002г. |
Примечание:
Данный материал не является исчерпывающей статьей по заявленной теме.
товил пояснительный текст к своему проекту.
Основное смотрите в исходных кодах.
В одном из моих проектов мне понабилось просматривать сообщения из журнала событий Windows от одного из источников. Почитав справочник MSDN, я решил, что необходимо сначала все-таки написать выбор всех сообщений из одного из журналов событий, а уж затем отфильтровать нужные мне. Нигде по конференциям и сайтам посвященным Delphi я не нашел ответа на мои вопросы как же там все устроено и решил разобраться сам. Что из этого получилось предоставляю на Ваш строгий суд. Обо всех ошибках и недочетах про сообщать мне по электронной почте .
Что же из себя представляет журнал событий и как с ним работать. Каждый из журналов хранится в системной директории. %SystemRoot%\system32\config\*.evt
Как известно их всего три:
В случае удачи, функция возвращает handle журнала сообщений. В противном случае будет возвращено Null. Для более подробной информации смотрите GetLastError.
Примечание
Для того, чтобы закрыть журнал событий, используйте функцию CloseEventLog.
The ReadEventLog function reads a whole number of entries from the specified event log. The function can be used to read log entries in chronological or reverse chronological order. BOOL ReadEventLog ( HANDLE hEventLog , // handle to event log DWORD dwReadFlags,, // how to read log DWORD dwRecordOffset, // offset of first record LPVOID lpBuffer, // buffer for read data DWORD nNumberOfBytesToRead,// bytes to read DWORD * pnBytesRead, // number of bytes read DWORD * pnMinNumberOfBytesNeeded // bytes required );
Параметры: hEventLog[in] Handle to the event log to read. This handle is returned by the OpenEventLog function. dwReadFlags [in] Specifies how the read operation is to proceed. This parameter must include one of the following values.
| Value | Meaning |
| EVENTLOG_SEEK_READ | The read operation proceeds from the record specified by the dwRecordOffset parameter. This flag cannot be used with EVENTLOG_SEQUENTIAL_READ. |
| EVENTLOG_SEQUENTIAL_READ | The read operation proceeds sequentially from the last call to the ReadEventLog function using this handle. This flag cannot be used with EVENTLOG_SEEK_READ. |
If the buffer is large enough, more than one record can be read at the specified seek position; you must specify one of the following flags to indicate the direction for successive read operations.
| Value | Meaning |
| EVENTLOG_FORWARDS_READ | The log is read in chronological order. This flag cannot be used with EVENTLOG_BACKWARDS_READ. |
| EVENTLOG_BACKWARDS_READ | The log is read in reverse chronological order. This flag cannot be used with EVENTLOG_FORWARDS_READ. |
В случае удачи, функция возвращает ненулевое значение. В противном случае будет возвращен 0. Для более подробной информации смотрите GetLastError.
Примечание:
When this function returns successfully, the read position in the error log is adjusted by the number of records read. Only a whole number of event log records will be returned.
Note
The configured filename for this source may also be the configured filename for other sources (several sources can exist as subkeys under a single logfile). Therefore, this function may return events that were logged by more than one source.
В принципе уже видно, что для открытия и работы с журналом нам необходимо получить на него указатель передав в функцию в качестве параметра наименование одного из трех журналов. А затем считывать записи в буфер и форматировать их. Как видно буфер который заполняет функция имеет структуру EVENTLOGRECORD.
typedef struct _EVENTLOGRECORD { DWORD Length; DWORD Reserved; DWORD RecordNumber; DWORD TimeGenerated; DWORD TimeWritten; DWORD EventID; WORD EventType; WORD NumStrings; WORD EventCategory; WORD ReservedFlags; DWORD ClosingRecordNumber; DWORD StringOffset; DWORD UserSidLength; DWORD UserSidOffset; DWORD DataLength; DWORD DataOffset; // // Then follow: // // TCHAR SourceName[] // TCHAR Computername[] // SID UserSid // TCHAR Strings[] // BYTE Data[] // CHAR Pad[] // DWORD Length; // } EVENTLOGRECORD, *PEVENTLOGRECORD;
Members
LengthSpecifies the length, in bytes, of this event record. Note that this value is stored at both ends of the entry to ease moving forward or backward through the log. The length includes any pad bytes inserted at the end of the record for DWORD alignment. ReservedReserved RecordNumberContains a record number that can be used with the EVENTLOG_SEEK_READ flag passed in a call to the ReadEventLog function to begin reading at a specified record. TimeGeneratedThe time at which this entry was submitted. This time is measured in the number of seconds elapsed since 00:00:00 January 1, 1970, Universal Coordinated Time. TimeWrittenSpecifies the time at which this entry was received by the service to be written to the logfile. This time is measured in the number of seconds elapsed since 00:00:00 January 1, 1970, Universal Coordinated Time. EventID Specifies the event. This is specific to the source that generated the event log entry, and is used, together with SourceName, to identify a message in a message file that is presented to the user while viewing the log. EventTypeSpecifies the type of event. This member can be one of the following values.
| Value | Meaning | ||||||||||
| EVENTLOG_ERROR_TYPE | Error event | ||||||||||
| EVENTLOG_WARNING_TYPE | Warning event | ||||||||||
| EVENTLOG_INFORMATION_TYPE | Information event | ||||||||||
| EVENTLOG_AUDIT_SUCCESS | Success Audit event | ||||||||||
| EVENTLOG_AUDIT_FAILURE | Failure Audit event |
Просто и ясно о PageMaker и Delphi
Дорогие коллеги, данной статьей я хочу показать вам основные принципы работы с Adobe Pagemaker из Delphi.
Итак небольшой экскурс -
Adobe Pagemaker - довольно распространенный в нашей стране пакет издательской верстки, в основном он применяется в газетах и журналах для подготовки материала к отпечатке в типографию. Данный пакет имеет в свое роде некоторые преимущества перед например Microsoft Word - ом при подготовке журнальных полос или верстке книг. На примере компонента TKDPageMaker я хочу показать вам возможность управления данной программой из Delphi.
Возможная область применения данного пакета - по работе мне приходилось создавать отчеты в виде брошюр
Итак начнем.
В документации поставляемой фирмой Adobe к данному пакету написано что PageMaker поддерживает динамический обмен данными (DDE) с любыми приложениями.
В данном компоненте реализована 3 основных метода , это - Property PathPageMaker : String Read FPathPageMaker Write SetPathPageMaker; метод служащий для указания пути к исполняемому файлу Pagemaker, используется для того что-бы TDDEClientConv запустил данное приложение в виде DDE сервера
Property Enable : Boolean Read FEnable Write SetEnable; метод используется для запуска Adobe PageMaker , т.е фактически для установки DDE соединения
Property UnitMeasurement : TUnitMeasurement Read FunitMeasurement Write SetUnitMeasurement; метод определяет единицы измерения которыми будет оперировать PageMaker при передаче команд. Например команда PageMaker Script Language PageSize позволяет установить размер страницы как в миллиметрах так и в дюймах - что бы не заботится об установки единиц измерения в командах и создан этот метод позволяющий гибко реализовать задание размеров в той форме в какой установил программист.
Рабочий пример
Ну, теперь - о главном. Вниманию уважаемой публики предлагается простой модуль с иерархией объектов, реализующих вышеописанные методы нотификации.Для удобства использования серверами, находящимися в DLL, и экспортирующими только функции (не классы), необходимые клиенту определения вынесены в отдельный unit:
| (********************************************************************* * Notifier object definitions * *********************************************************************) unit NotifyDef; interface uses Windows; const tnEvent = 0; // Use kernel object Event (SetEvent) tnThreadMsg = 1; // Use message to thread ID (PostThreadMessage) tnWinMsg = 2; // Use message to window HWND (PostMessage) tnCallBack = 3; // Asynchronous call user function TNotifierProc tnCallEvent = 4; // Asynchronous call object event handler TNotifierEvent type TNotifierProc = procedure(Owner: THandle; Msg,UserParam : dword); TNotifierEvent = procedure(Sender : TObject; Msg,UserParam : dword) of object; implementation end. |
Для создания объекта нотификатора заданного типа сервер может использовать функцию (см. модуль ):
function MakeNotifier(hEventObj,hSender : THandle; EventType : byte; MsgID,UserParam : dword) : TNotify;
| hEventObj | Хэндл низкоуровнего объекта, используемого для нотификации | хэндл события - результат вызова CreateEvent | ID потока (можно узнать GetCurrentThreadID) | хэндл окна | адрес процедуры |
| hSender | Условный хэндл объекта сервера - то, что сервер хочет сообщить о себе | не используется | TMessage.LParam | TMessage.LParam | Owner в TNotifierProc |
| EventType | Тип объекта нотификатора - см. константы в модуле | tnEvent | tnThreadMsg | tnWinMsg | tnCallBack |
| MsgID | Идентификатор сообщения | не используется | TMessage.Msg | TMessage.Msg | Msg в TNotifierProc |
| UserParam | Пользовательский параметр | не используется | TMessage.WParam | TMessage.WParam | UserParam в TNotifierProc |
Нотификатор типа "асинхронный вызов обработчика события" (tnCallEvent) нельзя создать через функцию MakeNotifier - требуется явный вызов конструктора. Это связано с тем, что адрес TNotifierEvent нельзя привести к четырехбайтному типу THandle. Параметры конструктора аналогичны параметрам MakeNotifier при EventType=tnCallback.
Далее приводится собственно текст юнита реализации библиотеки нотификаторов.
| (****************************************************************************** * The Collection of Notifier objects. * ******************************************************************************) unit Notify; interface uses Windows,NotifyDef; type TNotify = class protected hNotify : THandle; hOwner : THandle; Message, UParam : dword; public constructor Create(hEventObj : THandle); procedure Execute; virtual; property Owner : THandle read hOwner write hOwner; property Param : dword read UParam write UParam; end; TThreadNotify = class(TNotify) public constructor Create(hEventObj,hSender : THandle; MsgID,UserParam : dword); procedure Execute; override; end; TWinNotify = class(TThreadNotify) public procedure Execute; override; end; TCallBackNotify = class(TThreadNotify) public procedure Execute; override; end; TCallEventNotify = class(TThreadNotify) private fOnNotify : TNotifierEvent; public constructor Create(hEventObj : TNotifierEvent; hSender : THandle; MsgID,UserParam : dword); property OnNotify : TNotifierEvent read fOnNotify write fOnNotify; procedure Execute; override; end; function MakeNotifier(hEventObj,hSender : THandle; EventType : byte; MsgID,UserParam : dword) : TNotify; implementation function MakeNotifier(hEventObj,hSender : THandle; EventType : byte; MsgID,UserParam : dword) : TNotify; begin case EventType of tnEvent : result := TNotify.Create(hEventObj); tnThreadMsg : result := TThreadNotify.Create(hEventObj, hSender, MsgID, UserParam); tnWinMsg : result := TWinNotify.Create(hEventObj, hSender, MsgID, UserParam); tnCallBack : result := TCallBackNotify.Create(hEventObj, hSender, MsgID, UserParam); else result := nil; end; end; (*** TNotify ***) constructor TNotify.Create(hEventObj : THandle); begin hNotify := hEventObj; end; procedure TNotify.Execute; begin SetEvent(hNotify); end; (*** TThreadNotify ***) constructor TThreadNotify.Create(hEventObj,hSender : THandle; MsgID,UserParam : dword); begin inherited Create(hEventObj); Owner := hSender; Message := MsgID; UParam := UserParam; end; procedure TThreadNotify.Execute; begin PostThreadMessage(hNotify, Message, UParam, hOwner); end; (*** TWinNotify ***) procedure TWinNotify.Execute; begin PostMessage(hNotify, Message, UParam, hOwner); end; (*** TCallbackNotify ***) procedure TCallbackNotify.Execute; begin TNotifierProc(hNotify)(hOwner, Message, UParam); end; (*** TCalleventNotify ***) constructor TCalleventNotify.Create(hEventObj : TNotifierEvent; hSender : THandle; MsgID,UserParam : dword); begin OnNotify := hEventObj; Owner := hSender; Message := MsgID; UParam := UserParam; end; procedure TCalleventNotify.Execute; begin if assigned(OnNotify) then OnNotify(TObject(Owner), Message, UParam); end; end. |
Эта библиотечка родилась вследствие практической необходимости как результат обобщения наработок на данную тему. Теперь, создавая серверный модуль, я снабжаю его этим набором нотификаторов, чтобы он мог предоставить клиенту свободный выбор способа извещения.
Практическим примером использования объектов-нотификаторов является таймерный менеджер, которому будет посвящена следующая статья под названием "".
Специально для
Расположение эксперта внутри DLL библиотеки
Если вы хотите расположить вашего эксперта не в пакете, а в DLL библиотеке, библиотека должна экспортировать функцию INITWIZARD0001 следующего формата:| type TWizardRegisterProc = function(const Wizard: IOTAWizard): Boolean; type TWizardTerminateProc = procedure; function INITWIZARD0001(const BorlandIDEServices: IBorlandIDEServices; RegisterProc: TWizardRegisterProc; var Terminate: TWizardTerminateProc): Boolean stdcall; |
Для регистрации вашего эксперта вызовите внутри этой функции RegisterProc и передайте ей экземпляр заранее созданного класса вашего эксперта. BorlandIDEServices - указатель на основной интерфейс для работы со всей IDE. Отдельные части его мы рассмотрим далее. По окончании работы IDE или при принудительной выгрузке вашего эксперта будет вызвана функция Terminate, которую вы должны передать среде. Поместите полный путь к DLL в ключ реестра
HKEY_CURRENT_USER\Software\Borland\Delphi\7.0\Experts
или
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\7.0\Experts
Именем ключа может быть произвольная строка.
Эксперт будет запущен только при перезапуске среды, если она выполнялась. Вуаля!
Распределенные системы на основе COM+
Для создания распределенных систем, т.е. систем, элементы которых работают на нескольких компьютерах, в Delphi используется технология Midas. Данная технология имеет как достоинства, так и недостатки, связанные с тем, что для ее функционирования необходимо устанавливать дополнительные компоненты, осуществляющие связь между компьютерами и проводить их настройку. Оказывается, что использование COM+ дает возможность проектировать такие системы средствами, встроенными в Windows. Единственным условием, которое обязательно должно быть выполнено - в сети должен обязательно присутствовать контроллер домена, осуществляющий идентификацию пользователей. Причем не обязательно под Windows 2000. Вы можете использовать сеть с контроллером домена под Windows NT 4.0 с установленными апдейтами.Внимание!
Распределенные системы в одноранговой сети (WORKGROUP) на основе COM+ работать не будут.
В этом разделе мы рассмотрим пример создания простого приложения и организацию его работы под управлением COM+.
Для создания компонента воспользуемся Мастером New Transaction Object в Delphi 6, Рисунок 10 (заметим, что в Delphi 5 вам придется сначала создать библиотеку ActiveX и лишь затем вызвать Мастер MTS Object).
Затем с помощью Редактора Библиотеки Типов создадим в его интерфейсе метод SayHello (Рисунок 11) и напишем его реализацию.
| unit uHello; {$WARN SYMBOL_PLATFORM OFF} interface uses ActiveX, Mtsobj, Mtx, ComObj, HelloMTS_TLB, StdVcl; type THelloTest = class(TMtsAutoObject, IHelloTest) protected procedure SayHello(const Mess: WideString); safecall; { Protected declarations } end; implementation uses ComServ, Dialogs; procedure THelloTest.SayHello(const Mess: WideString); begin ShowMessage(Mess); end; initialization TAutoObjectFactory.Create(ComServer, THelloTest, Class_HelloTest, ciMultiInstance, tmBoth); end. |
Думаю, что приведенный код в комментариях не нуждается.
Далее с помощью утилиты Component Services сначала создадим пустой пакет (Рисунок 12), а затем установим в него наш компонент (Рисунок 13).
Теперь напишем простое Windows-приложение, которое будет вызывать единственный метод данного компонента. Код, который для этого используется, ничем не отличается от обычного вызова COM компонента.
| unit uTest; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TfrmMaim = class(TForm) btCallHello: TButton; procedure btCallHelloClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var frmMaim: TfrmMaim; implementation {$R *.dfm} uses HelloMTS_TLB; procedure TfrmMaim.btCallHelloClick(Sender: TObject); var HelloTest : IHelloTest; begin HelloTest := CoHelloTest.CreateRemote('AlexAD'); HelloTest.SayHello('Hell Word!'); end; end. |
В том, что компонент запущен под управлением MTS, легко убедиться с помощью той же утилиты Component Services - дело в том, что активный компонент начинает вращаться (Рисунок 15).
Если вы теперь возьмете и запустите созданное тестовое приложение на другом компьютере, и попытаетесь выполнить ту же операцию, то система выдаст сообщение о том, что компонент не зарегистрирован.
Теперь организуем связь между двумя компьютерами через COM+. Делается это очень просто. Сначала выберем в утилите Component Services мышкой папку, где установлен наш компонент и вызовем Application Export Wizard. Далее укажем, что мы хотим экспортировать не сам компонент, а только Application proxy (Рисунок 16).
После этого Мастер создаст нам MSI файл, где будет находиться вся информация для организации связи между компьютерами. Теперь останется только скопировать этот файл на нужный компьютер и щелкнуть по нему мышкой. При этом автоматически запустится Мастер, который проведет proxy в MTS. В этом легко убедиться с помощью утилиты Component Services.
Теперь, если вы запустите тестовое приложение, то на компьютере, где установлен MTS компонент, появится сообщение (Рисунок 15).
В прошлом к.т.н.,
доц. Рыбинской Государственной Авиационной Технологической Академии
и нач. отделения программирования НПО КРИСТА,
по программированию.
В настоящее время - Senior Software Engeener, RegScan Inc., PA, USA.
Расширенная обработка исключительных ситуаций
Описанный ниже механизм иллюстрирует один из методов регистрации программных ошибок времени выполнения, что может быть полезно при тестировании приложения. Идея заключается в комбинированном использовании компоненты, которая регистрирует все возникающие во время выполнения исключительные ситуации (Exceptions, в дальнейшем – ИС) в файле журнала и формы, которая визуализирует полученный LOG-файл. Предлагаемый способ обработки ИС обладает следующими преимуществами по сравнению со стандартным:
Расширяемость
Приведенная реализация имеет ряд ограничений. Первое и основное - это отказ от использования элементов в атрибутах XML документов. Это ограничение может быть снято переработкой кода парсера и процедур сохранения XML. Для отличия элементов от атрибутов в интерфейсе объектов можно придти к следующему соглашению:Второе ограничение, которое следует упомянуть, это способ описания коллекций. В приведенной реализации коллекции сохраняются в виде тега свойства, в который вложены описания элементов коллекции. Довольно часто в XML документах повторяющаяся группа тегов не заключается специально в теги, отделяющие эту группу. Это является препятствием для написания классов для обработки уже существующих документов. Поэтому необходимо предусмотреть и такую возможность.
Приведенная реализация будет постоянно обновляться, в том числе и на основании Ваших, уважаемый читатель, предложений. Последняя версия компонента с исходными текстами входит в библиотеку Globus VCL Extention Library.
Чудин Андрей, октябрь 2001г.
Специально для
Разбиение объектного пространства сцены путём построения octree-дерева
Have you ever stood and stared at it, Morpheus?
Marveled at its beauty. Its genius. Billions of people just living out their lives... oblivious.
Did you know that the first Matrix was designed to be a perfect human world?
Where none suffered, where everyone would be happy. It was a disaster. No one would accept the program.
Entire crops were lost.
Some believed we lacked the programming language to describe your perfect world.
But I believe that, as a species, human beings define their reality through suffering and misery.
Agent Smith. The Matrix.
Хотя в Королевстве статьи такого типа публикуются нечасто, я всё же попросил разрешения у Королевы сделать это, так как на тематику статей сайта никакие ограничения не накладываются, а сама программа написана на Object Pascal в среде Delphi. Для тех, кто читал мои ранние статьи по DirectX, хочу предупредить, что свои исследования в области прикладного API вроде DirectX и OpenGL я прекратил, и теперь больше занимаюсь алгоритмами, необходимыми для реализации трёхмерной графики. Ну да это так, к слову.
В компьютерной графике уже давно используются различные методы разделения объектного пространства на части с целью эффективной обработки только тех элементов сцены, которые наблюдатель может непосредственно увидеть через виртуальную "камеру". Всевозрастающая сложность геометрических сцен даёт прекрасную почву для исследования и разработки таких алгоритмов, причём если в компьютерной графике высокого уровня эти алгоритмы позволяют просто сократить время рендеринга сцены с месяцев до дней, то для графики реального времени они являются просто жизненно необходимыми - иначе понятие "интерактивная графика" просто бы отсутствовало.
Обычно тем, кто только начинает пробовать свои силы в 3D-пространстве, трудно понять, для чего же нужно разбиение пространства. Действительно, если опыты не выходят за рамки "солнышка и земли вокруг него", то заниматься этим нет смысла. Но допустим, мы взялись за рендеринг сложной сцены, вроде уровня Quake 3. Количество полигонов в сцене может достигать нескольких десятков тысяч (из года в год это значение неудержимо растёт), и если этот массив данных целиком отправлять на графический конвейер в каждом кадре, ни о какой интерактивности в игре и речи быть не может. Графический процессор будет тратить время на просчёт каждого полигона у каждого объекта, даже если в результате он жестоко не попадёт на экран.
В то же время лего заметить, что из всей сцены рельно в кадре постоянно видна лишь её небольшая часть. Очевидно, что объекты за "спиной" не будут видны однозначно, то же самое можно сказать об объектах, лежащих за границей зрения (рамками экрана). Если реализовать алгоритм, который позволяет выявить такие объекты, в результате его работы в графический ускоритель на обработку мы будем посылать сравнительно малую часть всей геометрии.
Здесь я собираюсь рассмотреть метод разделения объектного пространства, который называется octree (по-моему, от латинского octa - восемь, и английского tree - дерево). Восьмеричное дерево. Вообще подобные алгоритмы были разработаны ещё в 70-х годах, например, для точного описания ландшафта, но позже нашли своё применение в компьютерной графике.
Данный алгоритм производит разделение объектного пространства на восемь подпространств. Общую схему работы можно представить следующими шагами:
Самый простое и наглядное условие - это проверка на количество попадающих в узел геометрических примитивов (в нашем случае таким примитивом является треугольник). Это значение можно свободно варьировать, однако если вы хотите, чтобы скорость врендеринга была действительно хорошей, необходимо учитывать особенности современных видеокарт. Т. е. для отдельного вызова на графический конвейер необходимо подавать 200-300+ вершин, поэтому количество треугольников в узле должно быть достаточно большим - 100 и более. С другой стороны, бессмысленно делать это значение слишком большим - вне зависимости от того, видны ли все примитивы листа или нет, на графический конвейер они будут отправлены все, а это приведёт в большинстве случаев к бессмысленной обработке зачастую невидимой геометрии.
А теперь о том, как же именно применение данного алгоритма может помочь быстро откинуть части невидимой геометрии. Те элементы, что отображаются при рендеринге на экране, попадают в так называемый viewing frustum - пространство видимости. Графически оно выглядит вот так:
Рисунок 1. Viewing frustum
Теперь, в процессе рендеринга мы рекурсивно выполняем следующую процедуру: начиная с базового (root) куба, мы проверяем, попадает ли данный куб в поле зрения (viewing frustum). Если НЕТ - на этом всё и заканчивается, если же ДА - перемещаемся вглубь рекурсии на один шаг, т. е. поочерёдно проверяем видимость каждого из восьми подузлов корневого узла и т. д. Преимущество заключается в том, что если определено, что данный узел не виден, то можно смело не выводить и всю геометрию этого узла - она тоже будет не видна. Таким образом, ценой всего лишь нескольких проверок, мы отбросим значительную часть сцены. А в случае, если не виден корневой узел, на экран не будет выведено ничего. Сплошная экономия!
Представленная программа как раз и демонстрирует работу данного алгоритма. Из двоичного файла загружается сцена (я взял готовую модель для 3D Studio MAX), представляющая собой интерьер простой кухни. Для этой сцены строится octree-дерево, в качестве порогового количества примитивов в узле установлено значение 300. В сцене я специально разместил два высокополигональных объекта, чтобы можно было "прочувствовать" преимущество алгоритма. Это бутылки из-под кетчупа на столе. Как только они попадают в область видимости, fps резко падает, но при выходе их за пределы видимости fps возрастает. Если же направить камеру в пустоту, fps возрастает до максимально возможного, так как в этом случае рендеринг сцены не производится. Если бы мы не использовали алгоритм разбиения пространства, fps был бы неизменно низким, словно бутылки с кетчупом видны постоянно.
К сожалению, от достоинств алгоритма а нужно перейти к его недостаткам, коих немало. Первый из них - это возможное деления примитива ребрами кубов дерева, например, вот так:
Рисунок 2. Проблемный случай
Обычно примитив относят к тому узлу, в пределах которого лежат вершины, образующие примитив. К какому из узлов отнести треугольник в данном случае? Казалось бы, взять да и отнести его к узлу I. Но так делать нельзя, и вот почему. Предположим, что мы связали треугольник с узлом I - тогда, если в процессе рендеринга мы определили, что узел I не виден, то и треугольник выведен не будет. Однако при этом возможна ситуация, когда узлы II и III будут в пространстве вида - полигон "выпадет" из сцены. Для избежания этого примитив относят к узлу, если хотя бы одна вершина примитива находится в пределах узла. В данном случае при таком подходе один и тот же треугольник будет ассоциирован с узлами I, II и III. В принципе, это не так уж страшно, так как данные можно индексировать, и этим избежать значительных расходов памяти. Однако в процессе рендеринга, если видны все три узла, полигон придётся вывести три раза. А это уже неприятно. Тем более, что такой полигон обычно не один, их множество.
Кое-где пишут, что это не так страшно, но я не согласен. Если такой примитив, например, покрыт большой текстурой, скорость вывода упадёт в несколько раз. Да и вообще, такие КрамольныЕ мысли в интерактивной графике недопустимы! Поэтому я поступил так: если примитив не полностью лежит в узле, его индекс заносится в отдельный массив. В процессе рендеринга ведётся учёт всех отрисованных "дробных" примитивов в специальном буфере, и если при выводе данного треугольника его индекс совпадёт с одним из индексов в буфере, мы не рисуем этот треугольник. Как показал опыт, помечать примитивы не так уж медленно, гораздо более медленно выводить геометрию три-четыре раза подряд.
Всё бы хорошо, да с делением примитива есть ещё одна проблема. Допустим, узлы I, II и III не видны. Однако узел IV может всё же попадать в поле зрения камеры, и видно, что частичка полигона всё же может выпасть, вот так:
Рисунок 3. Полигон выпал
Что делать? Очевидно, что нельзя относить примитив к узлу, ориентируясь только на факт принадлежности вершины примитива к этому узлу. Наверное, все же вместо этого надо проверять, проходит ли РЕБРО примитива через пространство узла. Это может потребовать гораздо больше времени при построении дерева, но зато мы избежим выпадения полигонов. Кстати, структуру один раз построенного дерева можно записать в файл, и уже больше не строить его каждый раз при старте программы, а загружать из файла. В приведённом случае полигон придётся отнести ко всем четырём узлам.
Второй недостаток octree-дерева - это вывод всех объектов, находящихся в поле viewing frustum, но на самом деле в конечном счёте невидимых. Например, стена кухни может закрывать бутылки с кетчупом, но они всё равно будут отсылаться на конвейер (так как находятся в области viewing frustum), и fps будет низким. По-видимому, чистым octree-based алгоритмом здесь не обойтись, необходимо дополнительно реализовать так называемый Z-buffer, например, на тайловой основе. Коротко его работу можно описать так:
Вот примерно так можно будет определить, что бутылки с кетчупом находятся за стеной. К сожалению, всё это мною пока не реализовано :(
Представленная программа написана в IDE Delphi 5 без использования VCL, поэтому проблем с компиляцией в средах различных версий выше 3 я не предвижу. Используется API OpenGL (стандартный модудь Delphi opengl.pas), и дополнительный небольшой модуль myglext.pas, где я описал некоторые необходимые для работы программы расширения OpenGL (всё-таки удивительно, насколько стандартный модуль неполон в этом вопросе - ведь некоторые недокументированные в нём API-функции уже давно входят в ядро OpenGL и являются фундаментальными для 3D-графики). Для более эффективного рендеринга используется функция ядра glDrawElements() и не используются специфические расширения конкретных видеокарт, поэтому программа по идее должна работать на любом компьютере. Управление: мышью можно вращать камеру, а левой и правыми кнопками мыши двигать камеру вперёд-назад. Клавишей D включается/отключается отрисовка рёбер узлов дерева - можно как бы увидеть его структуру. Класиша W задаёт wireframe-режим.
Реализация алгоритма вполне работоспособна, но ещё недостаточно эффективна. Пораскинув мозгами, можно сделать несколько оптимизаций (чем автор и собирается заняться), а также попытаться избавиться от указанных мною ранее проблем.
Если вам есть что сказать — пишите
Скачать проект
Реализация языка шаблонов для Object Pascal на Perl
| Раздел Подземелье Магов | сев А.В. , дата публикации 24 января 2002г. |
Реализация приема данных из DDE сервера
Запрос данных с сервера в компоненте к сожалению не реализован функцией т.к. компонент в свое время был написан за два часа в очень скоростном режиме, если вы обратите внимание на некоторые функции то запрос данных с DDE сервера в них реализован примерно так var PcharReply : Array[0..1023] of char; begin PcharReply := DDE.RequestData('GetPMState'); В основе вызывается стандартная функция RequestData TDDEClientConv.Для более подробной информацие обратитесь в справку по TDDEClientConv.Обработка событий является одним из
| Раздел Подземелье Магов |
Обработка событий является одним из ключевых моментов в COM. Существует масса программ, для нормального функционирования которых требуется поддержка событий.
GUI пользователя должен уметь обрабатывать различное количество событий, например, таких как: нажатие на кнопку мыши, перемещение мыши по экрану и т.д. Приблизительно так же может возникнуть потребность обрабатывать события внутри объектов COM. В данной статье мы рассмотрим принцип работы свободно связанных событий и создадим наглядное приложение для демонстрации использования такого типа событий в COM+. (Для более детальной информации о события в COM+ смотрите статью А.Новика «Система поддержки событий COM+» на сайте журнала «Клиент-Сервер»).
Редактирование реквизитов таблицы
Эта операция производит в обработчике TConfiguratorFr.SpeedButton4Click главной формы конфигуратора. Действия протекают по стандартной схеме: сначала запоминаются текущие реквизиты структуры таблицы, а затем производит их корректировка с учетом информации, введенной пользователем. Допускается изменение имени таблицы, категории информации, к которой отнесена таблица (что эквивалентно изменению ее имени), а также пользовательских комментариев к ней.Как прекрасна была бы жизнь,
Как прекрасна была бы жизнь, если б можно было все насущные нужды разработчика удовлетворить только средствами языка разработки! Увы, нет в мире совершенства, как говорил Лис, и поэтому фирмы-разработчики средств разработки генерируют всё новые, всё более мощные среды разработки (IDE), а также развивают сами языки программирования - взять те же Delphi, BCB, C# : сравните языковые средства с Pascal и C++. Вспомните также, сколько дополнительных (встроенных в IDE и отдельных) инструментальных средств входит в поставку BCB и Delphi.Borland Software Corporation, отдав дань уважения OWL, задвинула её подальше и стала развивать Delphi и BCB на платформе VCL. Совершенно не вижу, почему бы благородным донам не поступить так же J.
Суть моего решения состоит в интеграции средства языка - компоненты - и дополнительного инструментального средства собственной разработки - DllWizard. Интерфейс-оболочку к DLL обеспечивает компонента TAskDll (исходный код - в архиве AskDll.zip). В её методах инкапсулированы:
Всё, что нам нужно - это написать подобный код. Именно эта часть работы наиболее тру-доёмка, и когда мы сможем выполнить её легко, быстро и безошибочно, это и будет красивым венцом нашей технологии.
Задача решается с помощью DllWizard в 3 прохода:
Итак, начинаем:
Рисунок 1
Рисунок 2
Имя DLL-ки является префиксом у всех сгенерированных файлов и у функции в модуле CPP. Исходный текст DLL и тестового приложения находится в архиве DllTest.zip
Подкаталог DLL содержит исходный текст библиотеки: UnitExample.cpp Подкаталог EXE содержит исходный текст тестового приложения: UnitDllTest.cpp и в подкаталоге DllWizard - сгенерированные файлы:
Подводим итоги. Ниже описан порядок
Подводим итоги. Ниже описан порядок разработки пользовательского приложения, им-портирующего функции из динамически подключаемой библиотеки функций:
Рисунок 3
Рисунок 4
9 октября 2001 г
Специально для
Скачать архив: (92 K)
| Примечания |
(1) — кстати, компиляция приложения и dll с пакетом vcl50 полностью снимает проблему дочерних окон и использование менеджера памяти BORLNDMM.DLL (подключение ShareMem) становится не только не нужным, но и опасным .
(2) — как ни странно, но и от Microsoft бывает что-нибудь хорошее…
(3) — когда одно приложение управляет другим или позволяет себе "уведомлять"другое приложение о своих событиях
(4) — когда приложения выполняются на разных компьютерах в локальной сети (или internet) и взаимодействуют друг с другом.
(5) — подробнее о VMT будет рассказано далее.
(6) — если произойдет "сдвиг" VMT, последствия могут быть непредсказуемыми -но фактический вызов будет неверным.
(7) — когда один пакет ссылается на другой, а тот, в свою очередь, на третий, а тот …
(8) — только выполняют при загрузке дополнительную работу
(9) — кстати, использование TActionList довольно хорошая практика
(10) — New/Package
(11) — объектно-ориентированное программирование
(12) — так называемый GUID - глобальный уникальный идентификатор
(13) — я всегда испытываю некоторый скепсис, когда слышу про то, что чего-то "нам надолго хватит". В памяти еще остались ощущения от программирования под 16 разрядные среды (DOS и Windows) с 64k барьером и 640k общей памяти (которой, по тогдашнему мнению Microsoft, должно было хватить надолго). Но, как мне кажется, возможностей GUID, по крайней мере, на наш век хватит. Тем более в пределах одного приложения.
(14) — функция QueryInterface более подробно обсуждается далее
(15) — кстати, возникновение такой ситуации свидетельствует о плохом проектировании программы и следует пересмотреть всю идеологию системы в целом.
(16) — в виду отсутствия в Delphi механизма множественного наследования, агрегация (то есть включение одного объекта в другой с транспортацией его свойств и методов в объект-контейнер) довольно часто применяется в Delphi.
(17) — в частности, при переводе компонента в элемент ActiveX
(18) — вместе с _AddRef и _Release она реализует интерфейс IUnknown, являющийся базовым интерфейсом для всех остальных интерфейсов (как TObject является базовым классом для всех классов Delphi). Для любителей порассуждать о том, какой язык лучше вот информация к размышлению: для реализации механизма интерфейсов (да и, пожалуй, полностью всего COM) в C++ (причем в классической реализации по Страуструпу) не нужно ничего, кроме быстрых и умелых рук. Тогда как в Delphi Object Pascal потребовалось для его поддержки пришлось вносить изменения в сам язык.
(19) — допустим, IUnknown
(20) — включая получение интерфейса IUnknown.
(21) — но следует более тщательней подходить к реализации пакета базовых классов. То есть нужно постараться предусмотреть все, что только можно, ибо после запуска проекта в самостоятельное плавание малейшее изменение в этом пакете может потребовать перекомпиляцию, причем как основного приложения, так и всех без исключения plugin's
(22) — правда, особого смысла я в этом не вижу
(23) — а вот это может оказаться полезным (одна интеграция с MS Office'ом стоит многого)
(24) — Библиотека поддержки COM в Delphi это использует на полную катушку
(25) — пока не будет проинициализировано внутренне поле FVCLComObject TComponent. А это случится только при создании на основе TComponent ActiveX объекта.
(26) — если вы не хотите все испортить :)
С учетом критики и дополнений
| Раздел Подземелье Магов | Статья обновлена |
Если кому-то требуется что-то другое - дерзайте, я с удовольствием прочту на "Королевстве" что и как у вас получилось.
Handle = Хэндл = Рукоятка :)
Хочу предложить 2 способа:
Рассмотрим их более подробно на примерах.
| Раздел Подземелье Магов | Автор Александр Галилов дата публикации 05 ноября 1999г. |
Введение В этой статье рассматривается проектирование сервера удаленного доступа под Windows 95/98, позволяющего осуществлять подключение клиентов к командному интерпретатору COMMAND.COM. Прошу читателей отнестись с пониманием к возможным ошибкам и неточностям, т.к. я сравнительно недавно занялся данной темой.
Приведенный в статье пример реализован на C++ Builder 1 и Delphi 3. Обратите внимание на то, что автор НЕ ТЕСТИРОВАЛ примеры Win NT. Имеются все основания предполагать некорректность их работы в этой операционной системе. Если хотите - проверьте.
Под WindowsNT прилагаемый проект не работает, проверено. Что, впрочем, автор и не обещает.
Лена Филиппова
Часть 1 Первая часть статьи посвящена вопросу построения внутрисистемного интерфейса сервера удаленного доступа. Здесь под термином "внутрисистемный интерфейс" подразумевается способ взаимодействия нитей (threads) сервера непосредственно с программой, производящей выполнение пользовательских запросов. В данном случае пользовательские запросы поступают во всем известный командный интерпретатор COMMAND.COM (кстати, в Windows95/98 этот файл имеет формат EXE). Для организации взаимодействия с командным интерпретатором я использовал механизм неименованных трубок (anonymous pipes). Данный механизм был выбран по причине отсутствия в Win95 таких средств, как именованные трубки (Named Pipes) в Win NT. Именованные трубки позволяют реализовать рассмотренный здесь пример со значительно меньшими усилиями. Практически отличия Win NT и Win95 таковы, что простой, в принципе, механизм приходится реализовывать весьма нетривиальным способом.
Трубка - это по сути канал передачи данных. Трубка имеет два файловых идентификатора - один для записи данных, другой - для чтения имеющейся в трубке информации. Порядок продвижения байтов в трубке - FIFO (первый поступивший байт первым оказывается на выходе). С помощью API функции CreateProcess мы запускаем командный процессор, но при этом стандартные ввод и вывод перенаправляем на наши трубки. После проделывания всех этих операций мы получаем пару файловых идентификаторов, при помощи которых можем общаться с "Сеансом MS-DOS", однако, имейте ввиду, что этот механизм НЕ ПОЗВОЛЯЕТ получать/принимать данные с не стандартного ввода (STDIN) и вывода (STDOUT), т.е. Вы не сможете работать через трубки с Norton Commander или Far manager, хотя без проблем можете их запустить из командного интерпретатора COMMAND. А вот использовать все команды DOS (даже format d:) - это запросто :). Ничего не мешает работать и с другими программами, имеющими стандартный ввод-вывод, например Турбо ассемблер (TASM).
Теперь немного уточню насчет использования трубок. Конечно, pipes - это не изобретение Микрософт. Когда-то их описание я обнаружил в руководстве системного программирования под Unix, но подозреваю, что и там они появились не впервые. Вот что написано про трубки в Win32 Developer's References:
A pipe is a communication conduit with two ends; a process with a handle to one end can communicate with a process having a handle to the other end.
Рассмотрим более подробно создание трубки. Функция CreatePipe создает трубку, предоставляемую программисту в виде "двух концов" - идентификаторов:
BOOL CreatePipe( PHANDLE hReadPipe, // address of variable for read handle
PHANDLE hWritePipe, // address of variable for write handle
LPSECURITY_ATTRIBUTES lpPipeAttributes, // pointer to security attributes
DWORD nSize // number of bytes reserved for pipe );
hReadPipe и hWritePipe - указатели на идентификаторы. Идентификаторы получают значение при выполнении этой функции.
lpPipeAttributes - если Вы в Win95/98 можете это опустить и указать просто NULL, если вы в Win NT - см. Win32 Developer's References.
nSize- предположительный размер буфера. Система опирается на это значение для вычисления реального размера буфера. Этот параметр может быть равным нулю. В этом случае система выберет размер буфера "по умолчанию", но какой именно - я не знаю.
Если трубка создана, функция возвратит ненулевое значение, в случае ошибки - вернет нуль.
Следует заметить, что для операций с трубками используются функции ReadFile и WriteFile. Причем операция чтения завершается только после того, как будет что-нибудь прочитано из трубки, а операция записи завершается после помещения данных в собственную очередь трубки. Если очередь пуста, ReadFile не завершиться, пока в трубку не поместит данные другой процесс или нить с помощью функции WriteFile. Если очередь заполнена то WriteFile не завершиться до тех пор, пока другой процесс или нить не прочитает данные из трубки с использованием ReadFile. Для общения с командным интерпретатором нам понадобится две трубки - одна для пересылки байтов "туда", другая - для получения информации из досовской сессии. Теперь обратим наше внимание на функцию CreateProcess - несомненно, очень важную и нужную (про функцию WinExec - не говорим).
BOOL CreateProcess( LPCTSTR lpApplicationName,
// pointer to name of executable module
LPTSTR lpCommandLine, // pointer to command line string
LPSECURITY_ATTRIBUTES lpProcessAttributes, // pointer to process security attributes
LPSECURITY_ATTRIBUTES lpThreadAttributes, // pointer to thread security attributes
BOOL bInheritHandles, // handle inheritance flag
DWORD dwCreationFlags, // creation flags
LPVOID lpEnvironment, // pointer to new environment block
LPCTSTR lpCurrentDirectory, // pointer to current directory name
LPSTARTUPINFO lpStartupInfo, // pointer to STARTUPINFO
LPPROCESS_INFORMATION lpProcessInformation // pointer to PROCESS_INFORMATION );
lpApplicationName и lpCommandLine - указатели на "нуль-терминированные" (PChar) строки с именем запускаемого модуля (напр. "c:\command.com") и с командной строкой, которая будет передана запущенной программе в качестве аргумента. Если lpApplicationName равен нулю, то имя запускаемой программы должно быть первым в строке lpCommandLine и отделено пробелами от аргументов. Для Win NT - см. подробности в Win32 Developer's References.
lpProcessAttributes - в Win95/98 игнорируется, установите его в нуль. Для Win NT - см. подробности в Win32 Developer's References.
lpThreadAttributes - тоже, что и для lpProcessAttributes.
bInheritHandles - показывает как наследуются идентификаторы из вызывающего процесса. Если равно TRUE, то все идентификаторы, которые могут наследоваться, наследуются новым процессом. Унаследованные идентификаторы имеют то же самое значение и привелегии, что и оригинальные.
dwCreationFlags - определяет дополнительные флаги. Могут иметь следующие значения (список не полный, только для нашей задачи):
CREATE_DEFAULT_ERROR_MODE - новый процесс не наследует режим ошибок (error mode) от вызывающего процесса, вместо этого CreateProcess назначает новому процессу режи по умолчанию.
CREATE_NEW_CONSOLE - новый процесс создает новую консоль вместо родительской консоли. Этот флаг нельзя использовать вместе с флагом DETACHED_PROCESS.
DETACHED_PROCESS - для консольных процессов - новый процесс не имеет доступа к консоли родительского процесса.
HIGH_PRIORITY_CLASS - высокий приоритет. Используется в критичных ко времени выполнения процессах.
IDLE_PRIORITY_CLASS - нити процесса выполняются только при простое системы (idle).
NORMAL_PRIORITY_CLASS - приоритет для обыкновенных процессов без специальных задач.
REALTIME_PRIORITY_CLASS - наивысший приоритет. Системные сообщения могут теряться при выполнении потока с этим приоритетом.
lpEnvironment - указатель на среду окружения. Указывает на блок нуль-терминированных строк вида ИМЯ=ЗНАЧЕНИЕ. Сам блок завершается двумя нулевыми байтами для блока строк в формате ANSI и четырьмя нулевыми байтами для блока строк в формате UNICODE (см. подробности в Win32 Developer's References).
lpCurrentDirectory - указатель на нуль-терминированную строку, содержащую текущий каталог. Если указатель равен NULL, то текущий каталог тот же, что и у родительского процесса.
lpStartupInfo - указатель на структуру STARTUPINFO , которая определяет как должно появляться оконо для нового процесса.
lpProcessInformation - указатель на структуру PROCESS_INFORMATION , заполняемую функцией CreateProcess. Эта структура содержит информацию о запущенном процессе.
Теперь более подробно рассмотрим структуры STARTUPINFO и PROCESS_INFORMATION .
STARTUPINFO содержит следующие поля:
DWORD cb - размер структуры в байтах
LPTSTR lpReserved - не используется
LPTSTR lpDesktop - только в Win NT, подробности см. Win32 Developer's References
LPTSTR lpTitle - указатель на нуль-терминированную строку-заголовок консоли для консольных приложений
DWORD dwX - игнорируется, если не установлен флаг STARTF_USEPOSITION в dwFlags. Определяет координаты левого верхнего угла создаваемого окна в пикселях по горизонтали. Подробности см. Win32 Developer's References
DWORD dwY - игнорируется, если не установлен флаг STARTF_USEPOSITION в dwFlags. Определяет координаты левого верхнего угла создаваемого окна в пикселях по вертикали. Подробности см. Win32 Developer's References
DWORD dwXSize- игнорируется, если не установлен флаг STARTF_USESIZE в dwFlags. Определяет размер создаваемого окна в пикселях по горизонтали. Подробности см. Win32 Developer's References
DWORD dwYSize- игнорируется, если не установлен флаг STARTF_USESIZE в dwFlags. Определяет размер создаваемого окна в пикселях по вертикали. Подробности см. Win32 Developer's References
DWORD dwXCountChars- Игнорируется, если не установлен флаг STARTF_USECOUNTCHARS. Для консольных приложений, создавших новую консоль, определяет размер экранного буфера по горизонтали. Для GUI приложений всегда игнорируется
DWORD dwYCountChars- Игнорируется, если не установлен флаг STARTF_USECOUNTCHARS. Для консольных приложений, создавших новую консоль, определяет размер экранного буфера по вертикали. Для GUI приложений всегда игнорируется
DWORD dwFillAttribute- Игнорируется, если не установлен флаг STARTF_USEFILLATTRIBUTE. Определяет начальные атрибуты (цвет текста и фона) для консольных приложений. Игнорируется для GUI-приложений. Может принимать значения: FOREGROUND_BLUE, FOREGROUND_GREEN, FOREGROUND_RED, FOREGROUND_INTENSITY, BACKGROUND_BLUE, BACKGROUND_GREEN, BACKGROUND_RED и BACKGROUND_INTENSITY. Например FOREGROUND_RED | BACKGROUND_RED | BACKGROUND_GREEN | BACKGROUND_BLUE даст красный текст на белом фоне
DWORD dwFlags- Битовое поле, показывающее какие поля структуры STARTUPINFO следует учитывать при создании окна. Могут использоваться любые комбинации значений (список не полный, подробности см. Win32 Developer's References): STARTF_USESHOWWINDOW- Если этот флаг не установлен, то wShowWindow игнорируется
STARTF_USEPOSITION- Если этот флаг не установлен, то dwX и dwY игнорируются
STARTF_USESIZE- Если этот флаг не установлен, то dwXSize и dwYSize игнорируются
STARTF_USECOUNTCHARS- Если этот флаг не установлен, то dwXCountChars и dwYCountChars игнорируются
STARTF_USEFILLATTRIBUTE- Если этот флаг не установлен, то dwFillAttribute игнорируется
STARTF_USESTDHANDLES- Если установлен этот флаг, присвойте идентификаторы стандартного ввода, стандартного вывода и стандартной ошибки полям hStdInput, hStdOutput, и hStdError соответственно. Чтобы это работало, параметр fInheritHandles при вызове CreateProcess должен быть равен TRUE.
WORD wShowWindow- Игнорируется, если не установлен флаг STARTF_USESHOWWINDOW. Если флаг STARTF_USESHOWWINDOW установлен, присвойте этому полю константу, определяющую способ отображения главного окна, например SW_MINIMIZE
WORD cbReserved2- Зарезервировано, должно равняться нулю
LPBYTE lpReserved2- Зарезервировано, должно равняться нулю
HANDLE hStdInput- Игнорируется, если не установлен STARTF_USESTDHANDLES. Если флаг STARTF_USESTDHANDLES установлен, см. пункт про STARTF_USESTDHANDLES
HANDLE hStdOutput- -""-
HANDLE hStdError- -""-
Структура PROCESS_INFORMATION содержит следующие поля: HANDLE hProcess- Дескриптор созданного процесса
HANDLE hThread- Дескриптор первичной нити процесса (primary thread)
DWORD dwProcessId- Идентификатор процесса
DWORD dwThreadId- Идентификатор первичной нити процесса
Заполнять поля структуры PROCESS_INFORMATION не нужно, они заполняются при вызове функции CreateProcess.
Рассмотрим пример использования трубок и функции CreateProcess для обмена данными с COMMAND.COM
var stinfo: TStartupInfo; prinfo: TProcessInformation; ReadPipe,WriteToCommand,ReadFromCommand,WritePipe: integer; // обнуляем поля структур для CreateProcess FillChar(stinfo,sizeof(TStartupInfo),0); FillChar(prinfo,sizeof(TProcessInformation),0); // пытаемся выполнить CreatePipe для первой и второй трубки if (not CreatePipe(ReadPipe,WriteToCommand,nil,PipeSize)) or (not CreatePipe(ReadFromCommand,WritePipe,nil,PipeSize)) then ErrorCode:=1 else begin stinfo.cb:= sizeof(stinfo); stinfo.lpReserved:= nil; stinfo.lpDesktop:= nil; stinfo.lpTitle:= nil; stinfo.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW; stinfo.cbReserved2:= 0; stinfo.lpReserved2:= nil; stinfo.hStdInput:= ReadPipe; stinfo.hStdOutput:= WritePipe; stinfo.hStdError:= WritePipe; stinfo.wShowWindow:= SW_HIDE; // запускаем COMMAND.COM CreateProcess(CommandPath,nil,nil,nil,true, CREATE_DEFAULT_ERROR_MODE or NORMAL_PRIORITY_CLASS, nil,CurrentDirectory, stinfo,prinfo) После выполнения этого фрагмента мы имеем в итоге запущенный командный интерпретатор и пару файловых идентификаторов для приема/передачи символьных сообщений между COMMAND.COM и нашей программой. Сейчас самое время решить, каким образом реализовать обмен данными с трубками.
Казалось бы, что трубки вполне заменяют очереди, но это не совсем так. Обратившись к трубке для чтения символа, мы попадем в очень неприятное положение в случае, если трубка окажется пустой. Функция чтения не завершиться, пока не прочитает указанное количество символов. То же самое относится и к попытке записи символа в заполненную трубку. Выход заключается в создании двух нитей, одна из которых занимается считыванием символов и их постановкой в очередь на обработку, а другая - передачей символов из очереди в трубку.
Другой вариант - вместо отдельных очередей реализовать механизм Callback - процедур, например, по аналогии с оконными процедурами в Windows. В таком случае нити будут вызывать указанную им процедуру по мере надобности, т.е. если из досовской сессии поступает какая-либо информация, то вызывается процедура обработки входящих символов, а если есть возможность для передачи информации в сеанс MS-DOS - вызывается процедура передачи символов. Причем в последнем случае, возможно, не будет подлежащих передачи данных, тогда вызванная процедура должна сообщить об этом вызывающей нити специальным зарезервированным кодом. Таким образом, существует два основных способа обмена информацией с трубками - синхронный, когда используются Callback- процедуры и асинхронный - с использованием очередей ввода-вывода.
Приведенная в примере программа позволяет очень легко реализовать любой из этих способов. Ядро системы представлено в виде DLL, поэтому Вы можете использовать его не только в программах на Delphi.
Это дает нам возможность из основной нити программы обращаться к нашим очередям в совершенно произвольные моменты времени. Однако, следует учесть некоторые детали, касающиеся разделения нитями ресурсов. Необходимо гарантировать, что при обращении к очереди из основной нити программы мы не прервем операции с тои же очередью, производимые нитями, работающими с трубками. То же самое касается и Callback-процедур. Для избежания этого конфликта используется механизм критических секций. Критическая секция - это объект, поддерживаемый системой и разделяемый между двумя или более нитями. Суть работы критической секции состоит в том, что перед выполнением некоторого участка кода, которое нельзя прерывать, нить вызывает метод Enter, а перед завершением выполнения критического участка - метод Leave. Если во время выполнения критического участка другая нить вызовет метод Enter той же самой критической секции, то выполнение этой нити будет остановлено внутри метода Enter до тех пор, пока "предыдущая" нить, захватившая критический участок не вызовет метод Leave Этот механизм предотвращает доступ нитей к критическому участку, если он уже выполняется. Все нити для конкретного критического участка должны использовать один и тот же разделяемый объект критической секции.
Далее в примере используются функции API ReadFile и WriteFile. Сначала я опишу их, опираясь на Win32 Developer's References.
BOOL ReadFile( HANDLE hFile,// handle of file to read LPVOID lpBuffer,// address of buffer that receives data DWORD nNumberOfBytesToRead,// number of bytes to read LPDWORD lpNumberOfBytesRead,// address of number of bytes read LPOVERLAPPED lpOverlapped// address of structure for data );
hFile- Идентификатор файла для чтения. Должен быть создан с режимом доступа к файлу GENERIC_READ
lpBuffer- Указатель на буфер, в который будут помещены загруженные прочитанные данные
nNumberOfBytesToRead- Задает число байт, которые нужно прочитать
lpNumberOfBytesRead- Указатель на переменную, которая получит значение количества прочитанных байт
lpOverlapped- Указатель на структуру OVERLAPPED. В примере не используется. Для более подробной информации см. Win32 Developer's References
BOOL WriteFile( HANDLE hFile,// handle to file to write to LPVOID lpBuffer,// pointer to data to write to file DWORD nNumberOfBytesToRead,// number of bytes to write LPDWORD lpNumberOfBytesRead,// pointer to number of bytes written LPOVERLAPPED lpOverlapped// pointer to structure needed for overlapped I/O );
hFile- Идентификатор файла для записи. Должен быть создан с режимом доступа к файлу GENERIC_WRITE
lpBuffer- Указатель на буфер, из которого будет записываться информация
nNumberOfBytesToRead- Задает число байт, которые нужно записать
lpNumberOfBytesRead- Указатель на переменную, которая получит значение количества записанных байт
lpOverlapped- Указатель на структуру OVERLAPPED. В примере не используется. Для более подробной информации см. Win32 Developer's References
Обе описанные функции возвращают ненулевое значение в случае успешного завершения
//============================================================================= // Получение символа из очереди. Если символа в очереди нет - возвращает -1, // если символ есть - возвращает код символа (не char, а int !!!) function TFlowFromCommand.Get: integer; begin // входим в критическую секцию cs.Enter; Result:=GetQueue(end_chain,start_chain,chain_data,CHAIN_SIZE_FROM_COMMAND); // покидаем критическую секцию cs.Leave; end; //============================================================================= // устанавливает символ в очередь. Если символ в очередь установлен, // функция возвращает 1, если в очереди нет места - возвращает 0 function TFlowFromCommand.Put(c: char):integer; begin // входим в критическую секцию cs.Enter; Result:=PutQueue(c,end_chain,start_chain,chain_data,CHAIN_SIZE_FROM_COMMAND); // покидаем критическую секцию cs.Leave; end; //============================================================================= // вызов Callback-процедуры для передачи символа в основную нить procedure TFlowFromCommand.VCLExec; begin CallBackReceive(c,self); end; //============================================================================= procedure TFlowFromCommand.Execute; var read: integer; begin // входим в цикл repeat // если попытка чтения символа из трубки вызвала ошибку c:=0; if (not ReadFile(Pipe,c,1,read,nil)) then begin // отдаем оставшуюся часть кванта времени системе Sleep(0); continue; end // иначе делаем попытки поставить символ в очередь пока это наконец не // удасться успешно выполнить или вызываем обработчик, если он установлен else if @CallBackReceive=nil then while(Put(chr(c))=0) do Sleep(0) else begin gcs2.Enter; Synchronize(VCLExec); gcs2.Leave; end; until (Terminated or Suspended); end; //=============================================================================
Теперь у нас есть две очереди и методы Get и Put для доступа к ним. Еще мы имеем возможность "подцепить" Callback-процедуры и работать без использования очередей. Мы можем в любой момент воспользоваться этими методами для осуществления обмена информацией между запущенным командным интерпретатором и основной нитью нашей программы. Также мы можем использовать методы доступа к очередям совершенно произвольно в других нитях процесса.
Пример реализации описанного в статье механизма (C++Builder 1, Delphi 3) Вы можете скачать (16 K)
Александр Галилов
Сервер удаленного доступа. Часть II
| Раздел Подземелье Магов | Автор Александр Галилов дата публикации 11 ноября 1999г. |
Предисловие ко второй части
В первой части статьи был рассмотрен пример построения внутрисистемного интерфейса сервера удаленного доступа. К сожалению, неожиданно стали очевидными некоторые моменты, делающие использование DLL нежелательным. Во-первых, метод Synchronize далеко не всегда нормально работает в нитях (threads), созданных внутри DLL. Т.е. при вызове Synchronize(Something) метод Something не запускается. Этот эффект наблюдается только при использовании DLL и очевиднее всего именно в Win NT, что и послужило основной причиной неработоспособности примера в этой ОС. Во-вторых в Win 95/98 также есть ряд условий, отличных от таковых в Win NT, при которых Synchronize внутри DLL работает неправильно. В силу сложившихся обстоятельств в новом примере предоставляю исходник DLL, не использующей вышеупомянутый метод. Однако, при ее использовании остается проблема синхронизации с "main VCL thread". Мною были также исправлены "глюки" с обработкой очередей в предыдущей версии DLL и дополнен заголовочный файл. В-третьих, учитывая дополнительную сложность использования функций DLL для доступа к ее нитям, я решил подготовить новый пример полнофункционального (с "натягом", конечно) сервера без использования каких бы то ни было DLL. Все принципы, описанные в первой части, в примере реализованы полностью. В ходе этой работы замечены некоторые особенности работы компонента TServerSocket, которые Вы заметите, если начнете с ним активно "общаться". Но это уже так, к слову.
Введение
Обеспечение обслуживания клиентов - неотъемлемая функция любого сервера удаленного доступа. Рассмотренный здесь пример не является исключением. Обслуживание клиента состоит из четырех основных стадий:
Аутентификация
В данном случае аутентификация заключается в запросе пароля у пользователя и проверке правильности введенного слова. Процесс аутентификации реализован в виде отдельной нити, внутри которой происходит циклический опрос сокета пользователя на предмет наличия введенных символов. Время опроса и длина вводимой цепочки символов ограничена соответственно 30 секундами и 32 символами. Символы с кодом менее 32 (пробел) считаются признаком конца строки. После того, как пароль будет введен, выполняется проверка введенного слова на наличие в списке допустимых паролей. Если список не содержит такого слова, то пользователю отправляется сообщение о неудачной попытке и связь разрывается, после чего завершается и сама нить. В случае правильного ввода пароля происходит инициализация другой нити, производящей запуск ДОСовской сессии или подключение к уже запущенной сессии.
Выделение ресурсов
Для выделения ресурсов используется нить внутри которой происходит запуск командного интерпретатора. Сразу же после запуска инициализируются нити ввода-вывода данных, а управляющая нить переходит в режим ожидания завершения работы командного интерпретатора. Каждая сессия имеет специальную структуру-описатель, в которой храниться состояние соединения, ссылка на сокет клиента и ссылка на нить, запустившую командный интерпретатор. Указатель на эту структуру храниться в списке пользователей и паролей который, в свою очередь, заполняется информацией при инициализации программы-сервера на основании файла PASSWORDS.LST (см. пример). Сама структура формируется непосредственно перед активизацией сессии.
Обслуживание
Обслуживание клиентов происходит следующим образом: обработчик события, возникающего при поступлении информации от клиента, направляет поступающие данные (символы, строки) на входную очередь нити которая переносит данные через трубку (pipe) в командный интерпретатор или в запущенную из него программу на стандартное устройство ввода (STDIN). Для того, чтобы поступающие данные попадали в требуемый сеанс MS-DOS, сокет-источник данных сравнивается с сокетом в структуре-описателе сесии (см. предыдущий параграф). Когда командный интерпретатор или запущенная из него программа пытается осуществить вывод символов на стандартное устройство вывода (STDOUT) происходит передача символов через трубку в нить, контролирующую выходящий из сеанса MS-DOS поток. Эта нить вызывает Call-back функцию которая на основании данных из структуры-описателя осуществляет передачу информации через требуемый сокет.
Отключение клиента
Отключение клиента осуществляется либо по инициативе клиента, либо по инициативе администратора, либо в результате сбоя в канале обмена данными. Если клиент завершил свою сессию командой EXIT, то ожидающая завершения командного интерпретатора нить сама инициализирует процесс завершения соединения. Во всех этих случаях механизм реализации отсоединения одинаков. Просто-напросто производится завершение соединения на требуемом сокете и изменение содержимого полей соответствующей структуры-описателя. Если же происходит завершение работы командного интерпретатора, то структура-описатель уничтожается, что свидетельствует о необходимости повторного создания сеанса MS-DOS при присоединении клиента. Если клиент отсоединился не завершив работу своего командного интерпретатора, то вся обработка, инициированная отключившимся клиентом на сервере, продолжается без участия клиента. В таком случае, при повторной установке соединения клиенту будет предоставлена та же сессия, которую он покинул, но, возможно, с продолжающимся или завершенным процессом выполнения ранее данного задания.
Пример (Delphi 3) Вы можете скачать (19 K)
Александр Галилов
Собственно сам PGPsdk
28 октября 1997 г. PGP, Inc. объявила о поставке PGPsdk сторонним производителям программного обеспечения. PGPsdk - это средство разработки для программистов на С, позволяющее разработчикам программного обеспечения встраивать в него стойкие криптографические функции. Можно сказать что в PGPsdk реализованы все функции пакета PGP, мало того - версия PGP начиная с 5.0 хранит криптографические функции в динамических библиотеках – dll (о том насколько это не безопасно – вопрос к Крису Касперски, я лишь скажу что насколько я силен в математике).PGPsdk - это динамическая библиотека, состоящая из трех файлов [табл. 1], поддерживающая базовые алгоритмы криптования (перечислены выше), гибкое управление ключами, сетевой интерфейс и др. (можно использовать одну библиотеку - PGP_sdk.dll, если Вы не будите использовать фирменный интерфейс пользователя от NAI и сетевую библиотеку).
Установка
Скачайте архив с PGPsdk [9], на момент написания статьи доступна версия 1.7.2 (должен заметить что архив занимает 3 с лишним мегабайт), необходимо его разархивировать и из каталога \Libraries\DLL\Release взять следующие файлы - табл. 1
| Табл.1 | |
| PGP_SDK.dll | для криптования, управление ключами и т.д. |
| PGPsdkUI.dll | (UI= user interface) интерфейсные штучки, если Вам нужно будет только шифровать/расшифровывать, то этот файл необязателен. Но очень полезен для ввода пароля, выбора получателей сообщений, генерации ключей и другое. |
| PGPsdkNL.dll | (NL= network library) сетевая библиотека для работы с сервером ключей или для transport layer security. Ее мы рассматривать не будем, но в ближайшем будущем я попытаюсь ее описать. |
Собственно распространять Вам приложение придется с этими файлами, подложить их необходимо или в системный каталог WINDOWS или в каталог вместе с приложением - механизм стандартный как и для всех dll, главное чтоб библиотеку было видно Вашему приложению.
Переходим к делу.
Для работы система предоставляет ряд низкоуровневых PGP API (Application Programmig Interface) функций. Заголовки (хеадеры, описания) этих функций поставляются вместе с пакетом на Ц и лежат в каталоге Headers. Если Вы как и я пишите на Delphi, можете сами сконвертировать их, а можете взять готовые тут [10]. Это проект по переводу Ц-ных хеадеров на любимый мною язык программирования. Занимается всем этим делом Стивен Хейлер (Steven R. Heller ).
Описатели переведены на Delphi по принципу как это сделано для Ц - разбросаны на кучи модулей (листинг 1). Все названия модулей аналогичны Ц-ным заголовкам, за исключением pgpEncode - переименовано в pgpEncodePas, из-за особенностей объявления в Delphi (нельзя чтоб имя процедуры совпадало с названием модуля).
| Листинг 1. Объявление используемых библиотек. uses // PGPsdk pgpEncodePas, pgpOptionList, pgpBase, pgpPubTypes, pgpUtilities, pgpKeys, pgpErrors, // always last pgpSdk; |
| Листинг 2. Пример использования PGPsdk через PGP API Var context : pPGPContext; keyFileRef : pPGPKeySet; defaultKeyRing : pPGPKeySet; foundUserKeys : pPGPKeySet; filter : pPGPFilter; countKeys : PGPUInt32; keyFileName : PChar; userID : PChar; inFileRef, outFileRef : pPGPFileSpec; inFileName, outFileName : PChar; Begin // Init от C++ context:=NIL; keyFileName:='pubring.pgp'; userID:=''; inFileName:='myInFile.txt'; outFileName:='myOutFile.txt.asc'; // Begin PGPCheckResult('sdkInit', PGPsdkInit); PGPCheckResult('PGPNewContext', PGPNewContext( kPGPsdkAPIVersion, context )); PGPCheckResult('PGPNewFileSpecFromFullPath', PGPNewFileSpecFromFullPath( context, keyFileName, keyFileRef )); PGPCheckResult('PGPOpenKeyRing', PGPOpenKeyRing( context, kPGPKeyRingOpenFlags_None, keyFileRef, defaultKeyRing )); PGPCheckResult('PGPNewUserIDStringFilter', PGPNewUserIDStringFilter(context, userID, kPGPMatchSubString, filter)); PGPCheckResult('PGPFilterKeySet', PGPFilterKeySet(defaultKeyRing, filter, foundUserKeys)); // Открываем файловые манипуляторы PGPCheckResult('PGPNewFileSpecFromFullPath', PGPNewFileSpecFromFullPath(context, inFileName, inFileRef)); PGPCheckResult('PGPNewFileSpecFromFullPath', PGPNewFileSpecFromFullPath(context, outFileName, outFileRef)); // // А вот здесь уже идет кодирование. // PGPCheckResult('PGPEncode', PGPEncode( context, [ PGPOEncryptToKeySet(context, foundUserKeys), PGPOInputFile(context, inFileRef), PGPOOutputFile(context, outFileRef), PGPOArmorOutput(context, 1), PGPOCommentString(context, PChar('Comments')), PGPOVersionString(context, PChar('Version 5.0 assembly by Evgeny Dadgoff')), PGPOLastOption(context) ] )); // // Освобождаем занимаемые ресурсы и контекст PGP // if (inFileRef<>NIL) then PGPFreeFileSpec(inFileRef); if (outFileRef<>NIL) then PGPFreeFileSpec(outFileRef); if (filter<>NIL) then PGPFreeFilter(filter); if (foundUserKeys<>NIL) then PGPFreeKeySet(foundUserKeys); if (defaultKeyRing<>NIL) then PGPFreeKeySet(defaultKeyRing); if (keyFileRef<>NIL) then PGPFreeKeySet(keyFileRef); if (context<>NIL) then PGPFreeContext(context); PGPsdkCleanup; End; |
Здесь реализован пример из [9] со страницы 39. Функция PGPCheckResult позаимствована у Стивена из его примеров - принимает два параметра - строковую и код выполнения функции PGP API, если была ошибка - генерируется исключение и на экран выводится описание ошибки с именем функции (Очень помогает для ловли ошибок, а при вызове dll-библиотеки, тем более написанной на другом языке – помогает избавиться от Access violation).
| Листинг 3. Функция PGPCheckResult. procedure PGPCheckResult(const ErrorContext: shortstring; const TheError: PGPError); var s : Array [0..1024] of Char; begin if(TheError<>kPGPError_NoError)then begin PGPGetErrorString(TheError, 1024, s); if(PGPGetErrorString(TheError, 1024, s) = kPGPError_NoError)then raise exception.create(ErrorContext + ' [' + IntToStr(theError)+'] : '+StrPas(s)) else raise exception.create(ErrorContext + ': Error retrieving error description'); end; end; |
Сам интерфейс к доступу функциям выполнен не плохо, продуманно и вызов их не должен вызвать затруднений у Вас.
Открыв ее я подумал - а не убрать ли мне все эти "stdcall;export;" и просто присоединить библиотеку к ехе-файлу (ну не устраивает меня хитросплетение dll). Сказано сделано.
| Раздел Подземелье Магов |
Содержание
За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье на есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга. Хотя стандарт DTD устаревает и следует переходить к использованию схем, будет полезным обеспечить возможность создания DTD для наших объектов.
Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().
Следующий код просматривает свойства объекта, составляет их список, а затем формирует из этого модель содержания для элемента. Для свойств классовых типов используется рекурсия. Поскольку при сериализации объекта мы не использовали атрибутов, то определений для них создавать нет необходимости.
Для всех неклассовых типов модель содержания это - (#PCDATA). К примеру, свойство объекта Tag: integer превращается в .
Отдельно подходим к коллекциям. Для них необходимо указать на множественность дочернего тега элемента коллекции. Например, для свойства TMyCollection модель содержания может выглядеть так: .
Продолжение
Создание и наследование элементов управления, редактирование особенностей
Редакторы-наследники TParticulEditor предполагают, что элемент управления TParticulEditor.Control будет "умещён в одну строку", т. е. данные, которые будут отображены в нём, можно отобразить в сравнительно "узком" элементе управления (20 пикселов). TParticulEditor имеет 4 стандартных наследника TEditEditor (редактор в виде TEdit), TButtonEditor (в виде TButton), TComboBoxEditor (в виде TComboBox), TCheckBoxEditor (в виде TCheckBox). В модуле автоматически регистрируются 11 основных типов данных, которые привязываются к редакторам следующим образом: к TEditEditor - строки, целые числа, действительные числа, к TButtonEditor - текст, выбор цвета и методы: без параметров, вычисление периметра элемента управления и масштабирование, к TComboBoxEditor - перечисление (в том числе и события), к TCheckBoxEditor - булевы величины.Рассмотрим TEditEditor. Он редактирует данные трёх типов (в модуле PrtEdits). Всю "соль" обработки осуществляют процедуры TExecutor: StringExecutor, IntegerExecutor и RealExecutor. Так, StringExecutor просто переприсваивает данные из строки ввода TEdit редактируемой особенности, IntegerEdit и RealEdit перед присваиванием делают проверку формата вводимого числа из TEdit. Таким же образом, благодаря TExecutor можно обрабатывать любые данные, вводимые в строку.
Немного остановлюсь на TButtonEditor. Он служит, как правило, для обработки сложных данных, редактирование которых производится в диалоговом окне. Таким образом, кнопка редактора TButton служит для вызова некоторого диалога (его инициализация и обработка производится внутри процедуры TExecutor). В него передаются кодированные данные (параметры Code и Info), редактируются, кодируются в строку и выдаются Result'ом. Следует обратить внимание, что если особенность только для чтения, то внутри TExecutor следует это учесть и изменить форму, запрещая редактирование данных. Также TButtonEditor служит для реализации методов. Если метод без параметров, то по клику на кнопке производится выполнение этого метода; если с параметрами - выводится диалоговое окно ввода параметров; если метод возвращает какой-либо результат, то он отображается в заголовке кнопки. В Delphi это реализуется маленькой кнопочкой с тремя точками.
Для создания нового элемента управления следует унаследовать его от TParticulControl и обязательно перекрыть методы GetTypeName, GetParticuls и SetParticul. Быстрое создание новых свойств, методов или событий выполняется с помощью процедур DoProperty, DoMethod и DoEvent. Например:
function TSample.GetTypeName: string; begin Result := 'Некоторый класс'; end; function TSample.GetParticuls: TParticulList; var P: TParticul; begin Result := TParticulList.Create; with Result do begin P := DoProperty('Просто строка', dtString, True, True, FString, '', False); Add(P); P := DoProperty('Ширина', dtInteger, Length(FString) <> 0, True, IntToStr(Width), '', False); Add(P); end; end; procedure TSample.SetParticul(Value: TParticul); begin if Value.Name = 'Просто строка' then FString := Value.Code; if Value.Name = 'Ширина' then Width := StrToInt(Value.Code); end; Теперь свойства отобразятся в Инспекторе на вкладке "Свойства" с заголовками "Просто строка" и "Ширина" (на русском!). При их редактировании выведутся соответствующие редакторы с соответствующими Executor'ами. Обращу внимание, что таким образом могут редактироваться как "реальные" свойства, так и просто поля, а, быть может, и выполнятся процедуры (что-то вроде Get и Set).
Теперь хочу коснуться наследования элементов управления. Как известно, Object Pascal не позволяет осуществлять наследование с ограничением видимости, что послужило причиной создания большого количества Custom'ов в VCL. В языке С++ эта возможность имеется (private-, protected- и public-наследование). Данный Инспектор позволяет производить имитацию private- и public-наследования. Это очень удобно, когда необходимо скрыть "лишние" особенности в потомках.
TPublicSample = class(TSample) ... TPrivateSample = class(TSample) ... implementation ... //наследуем все особенности предка и добавляем свои function TPublicSample.GetParticuls: TParticulList; begin Result := inherited GetParticuls; ... end; //добавляем только свои особенности function TPrivateSample.GetParticuls: TParticulList; begin Result := TParticulList.Create; ... end; Хочу ещё раз обратить внимание, что особенности элемента управления не имеют никакого отношения к реальным свойствам, событиям и методам. Можно обращаться к полям, методам, свойствам любой области видимости (а не только published). То есть, методы GetParticuls и SetParticul - это имитация области published.
В примере Example1 показаны реализация свойств и методов различных элементов управления (о событиях чуть попозже, там есть несколько тонкостей). TRectControl - пример элемента управления, TRoundRectControl - его public-наследник, TEllipticControl - его private-наследник. На форму выведены два TRectControl'а и по одному TRoundRectControl'у и TEllipticControl'у. Кнопка Button1 показывает/скрывает Инспектор.
Создание и отладка MTS объектов
MTS представляет собой оболочку, которая осуществляет поддержку транзакций, управление доступом и совместное использование ресурсов (resource pooling) в распределенных системах, построенных на основе COM.
В Delphi имеются Мастера, которые позволяют создавать MTS объекты, поддерживающие все возможности MTS.
Еще раз перечислим возможности, которые предоставляет пользователю MTS:
С помощью этих возможностей разработчик может создавать распределенные приложения, состоящие из функциональных частей, каждая из которых реализует одно или несколько бизнес правил (business logic). Для этой цели можно использовать либо MTS объекты (MTS objects) или MTS модули данных (MTS remote data modules). Эти компоненты располагаются в динамических библиотеках (DLLs), которые затем устанавливаются в MTS.
Созданные таким образом компоненты могут использоваться как обычными Windows приложениями, так и ActiveForm.
Создание MTS объектов
В Delphi 5 имеются два Мастера для создания MTS объектов. Первый, под названием MTS Object, создает компонент, похожий на обычный компонент Delphi. Второй, с именем MTS Data Module, создает модуль данных, похожий на одноименный компонент Delphi. Его можно использовать, как контейнер для размещения компонентов доступа к базам данных. Но, в общем-то, особой разницы между этими компонентами нет.Первый шаг, который необходимо сделать — создать новую ActiveX Library (Рисунок 1).
Второй - создать Data module с помощью Мастера создания MTS Data Module (Рисунок 2).
Далее необходимо выбрать потоковую модель (Threading model) и модель транзакций (Transaction model) для создаваемого компонента (Рисунок 3).
В том случае, если выбрана Single, MTS гарантирует, что только один вызов клиента будет обрабатываться в каждый момент времени. В этом случае полностью исключается влияние одного клиентского приложения на другое.
В том случае, если выбрана модель Apartment, то MTS гарантирует, что один экземпляр данного компонента в любой момент выполняет один запрос клиента, но не обязательно использует для этого один и тот же поток (thread). Поэтому нельзя использовать переменные потока (thread variables), поскольку нет гарантии, что последовательность клиентских вызовов будет обрабатываться тем же потоком данного компонента. Таким образом, для избежания конфликтов между потоками, нельзя использовать глобальные переменные или компоненты, которые находятся в модуле данных, если их одновременное использование может привести к таким конфликтам. Вместо этого следует использовать shared property manager.
В том случае, если выбрана модель Both, то это означает, что модуль работает так же, как и в случае Apartment, но обратные вызовы (callbacks), которые передаются клиенту, будут выполняться последовательно. Таким образом, можно не заботиться о влиянии их друг на друга.
Внимание!
Модель Apartment в MTS отличается от одноименной модели в терминологии DCOM (Distributed COM).
Вы так же должны выбрать один из вариантов поддержки транзакции. Доступны следующие опции: Requires a transaction. В этом случае, всякий раз, как только клиент будет обращаться к интерфейсу модуля данных, его обращение будет выполняться в контексте транзакции MTS. В том случае, если клиент работает в контексте транзакции, новая транзакция не будет создаваться. Requires a new transaction. При выборе этого варианта, каждый раз, как только к интерфейсу компонента будет происходить обращение, MTS автоматически будет создавать для него транзакцию. Supports transactions. В данном варианте модуль может работать в контексте транзакции MTS, но клиент должен поддерживать использовать контекст транзакции при вызове методов интерфейса. Does not support transactions. В этом случае модуль данных не может использоваться в контексте транзакции MTS.
Следует иметь в виду, что при установке компонента на MTS, модель транзакции можно будет изменить.
При этом можно указать максимально время, после которого транзакция будет автоматически прервана (transaction timeout). По умолчанию оно равно 60сек. Для того чтобы запретить автоматическое прерывание транзакции (например, при отладке приложения), следует установить это время равным нулю.
Для установки его следует с помощью утилиты Component Services выбрать компьютер, для которого следует изменить время транзакции и на странице Options провести соответствующие изменения (Рисунок 4).
В Delphi 6 процесс создания модуля данных практически совпадает с тем, что был описан выше, за исключением того, что новый проект будет создан автоматически, как только вы обратитесь к Мастеру Transaction Data Module Object (Рисунок 5).
При создании нового MTS data module, Delphi автоматически создает процедуру UpdateRegistry для поддержки технологии Midas, которая используется Borland.
| class procedure TTestD5.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); begin if Register then begin inherited UpdateRegistry(Register, ClassID, ProgID); EnableSocketTransport(ClassID); EnableWebTransport(ClassID); end else begin DisableSocketTransport(ClassID); DisableWebTransport(ClassID); inherited UpdateRegistry(Register, ClassID, ProgID); end; end; |
Процесс создания интерфейса полностью совпадает с тем, что используется в обычном COM компоненте, и поэтому здесь не рассматривается.
Создание поля в таблице
Создание поля может выполняться двумя путями: по ходу создания новой таблицы из диалога формирования списка полей TTbDefFr по кнопке Новое поле или же непосредственно из главной формы нашей платформы по кнопке NewF. В обоих случаях создается диалог формирования новой структуры поля FldDlgFr с тем отличием, что в первом случае работа происходит с буферной структурой таблицы FDbInterface.N_pTTableInfo, а во втором – с текущей структурой таблицы FpTTableInfo главной формы конфигуратора. В обоих случаях работа начинается с создания буферной структуры поляFDbInterface.Init_NpTFieldInfo;
После выхода из диалога FldDlgFr ход действий несколько отличается, но суть их одна и та же. В первом случае сначала идет «набивка структуры таблицы» FDbInterface.N_pTTableInfo списком структур полей и обновление информации на сервере производится в один прием, т.е. одновременно создается как таблица, так и поля в ней. Во втором случае эта операция выполняется для одиночной структуры поля, добавляемой в структуру таблицы, что требует лишь обновления структуры таблицы на сервере.
Создание pop-up меню своего компонента и кое-что еще о классе TComponentExpert
Давайте рассмотрим создание простейшего одноуровневого контекстного меню на своем компоненте, которое будет открываться при щелчке правой кнопкой по нему в самом верху контекстного меню Delphi.Прежде всего вам следует разделить код вашего компонента на Design-time и Run-time. Для этого перенесите ваш компонент в модуль, с названием, например, MyComponent.pas, а процедуры регистрации его в палитре компонентов (procedure Register и т.д.) в модуль, с названием, например, MyComponentReg. На такие меры приходится идти из-за того, что Borland не включила в исходные коды исходник файла Proxies.pas.
Итак, получим два файла:
MyComponent.pas:
| unit MyComponent; interface uses SysUtils, Classes; type TMyComponent = class(TComponent) private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } end; |
MyComponentReg.pas
| unit MyComponentReg; interface uses DesignIntf, DesignEditors, MyComponent, Classes, Dialogs; type TMyComponentEditor = class(TComponentEditor) private procedure ExecuteVerb(Index: Integer); override; function GetVerbCount: Integer; override; function GetVerb(Index: Integer): string; override; procedure Edit; override; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TMyComponent]); RegisterComponentEditor(TMyComponent, TMyComponentEditor); end; { TMyComponentEditor } procedure TMyComponentEditor.Edit; begin ShowMessage('TMyComponent component v1.0 by Rastrusny Vladislav'); end; procedure TMyComponentEditor.ExecuteVerb(Index: Integer); begin inherited; case Index of 0: //Действие при выборе первого определенного пункта меню end; end; function TMyComponentEditor.GetVerb(Index: Integer): string; begin case Index of 0: Result := 'Demo Menu Item 1'; //Название первого пункта меню end; end; function TMyComponentEditor.GetVerbCount: Integer; begin Result := 1; end; end. |
Рассмотрим теперь, что же тут написано. В первом файле просто определен компонент MyComponent. В нем вы определяете все свойства и методы вашего компонента. Все как обычно. Теперь - второй файл MyComponentReg. Он содержит процедуры регистрации компонента и процедуру регистрации редактора компонента (TComponentEditor). Этот редактор и будет отображать меню и прочие безобразия. Итак:
Определяем TMyComponentEditor как потомка TComponentEditor. Сам по себе этот класс является "воплотителем" интерфейса IComponentEditor, хотя нам все равно. Для того, чтобы все это заработало нам нужно будет переопределить стандартные методы класса TComponentEditor. Рассмотрим его:
| type TComponentEditor = class(TBaseComponentEditor, IComponentEditor) private FComponent: TComponent; FDesigner: IDesigner; public constructor Create(AComponent: TComponent; ADesigner: IDesigner); override; procedure Edit; virtual; function GetVerbCount: Integer; virtual; function GetVerb(Index: Integer): string; virtual; procedure ExecuteVerb(Index: Integer); virtual; procedure Copy; virtual; procedure PrepareItem(Index: Integer; const AItem: IMenuItem); virtual; property Component: TComponent; property Designer: IDesigner; end; |
Конструктор нам переопределять не нужно. Поэтому начнем с описания метода Edit. Метод Edit вызывается при двойном щелчке по компоненту. Вот так просто! При двойном щелчке на компоненте! Если метод не определен, то при двойном щелчке будет выполнен первый пункт меню, которое вы определили. Метод GetVerbCount: Integer должен возвращать количество определенных вами пунктов меню. Метод GetVerb(Index: Integer): string должен возвращать название пункта меню № Index. Метод ExecuteVerb(Index: Integer) вызывается при щелчке на пункте меню, определенном вами. Index - номер меню из метода GetVerb. В нем вы определяете действия, которые будут происходить при нажатии на ваш пункт меню. Метод Copy вызывается при копировании вашего компонента в буфер обмена Свойство Component как вы уже наверное догадались позволяет получить доступ к компоненту, на котором щелкнули мышью и т.п. Метод PrepareItem(Index: Integer; const AItem: IMenuItem) вызывается для каждого определенного вами пункта меню № Index и через параметр AItem передает сам пункт меню для настройки. Для работы нам нужно будет рассмотреть саму реализацию интерфейсас IMenuItem. Он определен в модуле DesignMenus.pas и является потомком интерфейса IMenuItems.
| IMenuItems = interface ['{C9CC6C38-C96A-4514-8D6F-1D121727BFAF}'] // public function SameAs(const AItem: IUnknown): Boolean; function Find(const ACaption: WideString): IMenuItem; function FindByName(const AName: string): IMenuItem; function Count: Integer; property Items[Index: Integer]: IMenuItem read GetItem; procedure Clear; function AddItem(const ACaption: WideString; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil; hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload; function AddItem(AAction: TBasicAction; const AName: string = ''): IMenuItem; overload; function InsertItem(const ACaption: WideString; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil; hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload; function InsertItem(Index: Integer; const ACaption: WideString; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil; hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload; function InsertItem(AAction: TBasicAction; const AName: string = ''): IMenuItem; overload; function InsertItem(Index: Integer; AAction: TBasicAction; const AName: string = ''): IMenuItem; overload; function AddLine(const AName: string = ''): IMenuItem; function InsertLine(const AName: string = ''): IMenuItem; overload; function InsertLine(Index: Integer; const AName: string = ''): IMenuItem; overload; end; |
| IMenuItem = interface(IMenuItems) ['{DAF029E1-9592-4B07-A450-A10056A2B9B5}'] // public function Name: TComponentName; function MenuIndex: Integer; function Parent: IMenuItem; function HasParent: Boolean; function IsLine: Boolean; property Caption: WideString; property Checked: Boolean; property Enabled: Boolean; property GroupIndex: Byte; property HelpContext: THelpContext; property Hint: string; property RadioItem: Boolean; property ShortCut: TShortCut; property Tag: LongInt; property Visible: Boolean; end; |
Что же касается процедуры RegisterComponentEditor, то она принимает два параметра: первый - класс компонента, для которого создается редактор свойств и второй - собственно сам класс редактора свойств.
| TPropertyEditor = class(TBasePropertyEditor, IProperty, IProperty70) protected procedure SetPropEntry(Index: Integer; AInstance: TPersistent; APropInfo: PPropInfo); override; protected function GetFloatValue: Extended; function GetFloatValueAt(Index: Integer): Extended; function GetInt64Value: Int64; function GetInt64ValueAt(Index: Integer): Int64; function GetMethodValue: TMethod; function GetMethodValueAt(Index: Integer): TMethod; function GetOrdValue: Longint; function GetOrdValueAt(Index: Integer): Longint; function GetStrValue: string; function GetStrValueAt(Index: Integer): string; function GetVarValue: Variant; function GetVarValueAt(Index: Integer): Variant; function GetIntfValue: IInterface; function GetIntfValueAt(Index: Integer): IInterface; procedure Modified; procedure SetFloatValue(Value: Extended); procedure SetMethodValue(const Value: TMethod); procedure SetInt64Value(Value: Int64); procedure SetOrdValue(Value: Longint); procedure SetStrValue(const Value: string); procedure SetVarValue(const Value: Variant); procedure SetIntfValue(const Value: IInterface); protected { IProperty } function GetEditValue(out Value: string): Boolean; function HasInstance(Instance: TPersistent): Boolean; { IProperty70 } function GetIsDefault: Boolean; virtual; public constructor Create(const ADesigner: IDesigner; APropCount: Integer); override; destructor Destroy; override; procedure Activate; virtual; function AllEqual: Boolean; virtual; function AutoFill: Boolean; virtual; procedure Edit; virtual; function GetAttributes: TPropertyAttributes; virtual; function GetComponent(Index: Integer): TPersistent; function GetEditLimit: Integer; virtual; function GetName: string; virtual; procedure GetProperties(Proc: TGetPropProc); virtual; function GetPropInfo: PPropInfo; virtual; function GetPropType: PTypeInfo; function GetValue: string; virtual; function GetVisualValue: string; procedure GetValues(Proc: TGetStrProc); virtual; procedure Initialize; override; procedure Revert; procedure SetValue(const Value: string); virtual; function ValueAvailable: Boolean; property Designer: IDesigner read FDesigner; property PrivateDirectory: string read GetPrivateDirectory; property PropCount: Integer read FPropCount; property Value: string read GetValue write SetValue; end; |
Предположим, нам нужно создать редактор для текстового свойства, при нажатии кнопки "…" в Object Inspector.
Объявим специальный тип этого свойства TMyComponentStringProperty = string;
Далее, в компоненте укажем свойство данного типа property MyProperty: TMyComponentStringProperty, далее в Run-time части компонента (MyComponentReg.pas) объявим класс TMyCSPEditor (в переводе: TMyComponentStringPropertyEditor :)), унаследовав его от класса TStringProperty, который в свою очередь является потомком рассматриваемого класса TPropertyEditor: type TMyCSPEditor = class(TStringProperty) . Переопределим в нем несколько методов таким образом (фрагменты файла):
| type TVRSIDBListViewExcludeColumnsPropertyEditor = class(TStringProperty) function GetAttributes: TPropertyAttributes; override; procedure Edit;override; end; -------------------------------------------------------------- procedure TVRSIDBListViewExcludeColumnsPropertyEditor.Edit; var Text: string; begin if InputQuery('Введите строковое значение',Text)=False then Exit; Self.SetValue(Text); end; function TVRSIDBListViewExcludeColumnsPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=[paDialog]; end; |
Метод Edit. Просто вызывается при щелчке на кнопке "…" в Object Inspector. В TStringProperty не переопределен. Метод SetValue(Text: string). Должен устанавливать значение свойства в переданную строку. В TStringProperty переопределен. Этот метод вызывается самим Object Inspector, когда пользователь вводит значение поля. Вы можете переопределить этот метод для установки вашего свойства в зависимости от значения, введенного пользователем. Если вы обнаруживаете ошибку в переданном параметре - вызовите исключение. Метод GetAttributes: TPropertyAttributes. Задает параметры свойства. Рассмотрим их по порядку.
Описания для остальных методов и свойств, к сожалению, найти не удалось, поэтому исследовать их можно только опытным путем.
По завершении создания редактора свойств не забудьте зарегистрировать его внутри метода register вызовом RegisterPropertyEditor(TypeInfo(), , , ); RegisterPropertyEditor(TypeInfo(TMyComponentsStringProperty), TMyComponent, '', TMCSPEditor);
Передав вместо имени свойства пустую строку, мы указали тем самым, что имя может быть любым. Так же пустую строку можно передать вместо имени компонента.
Вот, собственно, и все. Пишите свой редактор свойств, переопределяйте нужные методы и вперед!
Создание собственной среды разработки
До настоящего момента были показаны приёмы непосредственной работы с элементами-потомками TParticulControl. Эти приёмы, как уже упоминалось, годятся для проектирования таких систем, работающих только в режиме редактирования (яркий пример - САПРы). Но во многих системах редактируемые элементы используются как в "DesignTime", так и в "RunTime" (Word, HTML-редакторы и пр.). Ясно, что данный подход для них неприемлем.Данная проблема решена путём использования приёмов агрегации и установления прозрачности. Как уже было сказано ранее, TParticulControl имеет наследника TExternalControl, специально предназначенного для этой цели. Свойство ExternalObject элемента TExternalControl позволяет редактировать любые объекты (а не только компоненты!). Если объект не является наследником TControl, то он отображается, как в Delphi, квадратиком. TExternalControl располагается под редактируемым объектом, если тот является наследником TWinControl, в рабочем режиме, и над ним - в режиме редактирования.
Для того, чтобы обработать какой-либо объект, необходимо создать класс-потомок от TExternalControl для перекрытия методов GetTypeName, GetParticuls и SetParticul. Однако в отличие от TParticulControl в потомке TExternalControl методы служат для обработки свойств, полей, методов и событий не самого себя, а объекта ExternalObject. Перед использованием нового элемента управления необходимо присвоить его свойству ExternalObject редактируемый объект.
TExternalControl прозрачен, поэтому, в случае обработки потомка TControl будет отрисовываться именно потомок. В случае редактирования наследника от TWinControl необходимо "менять их местами" в режимах редактирования (TExternalControl.BringToFront) и рабочем (TExternal.SendToBack) для получения фокуса. В противном случае, невозможно будет добраться до нижнего.
В примере Example3 показано, как создать собственную среду разработки. Показано, как можно редактировать потомка TWinControl (TEdit внедрён в TParticulEdit), TControl (TImage в TParticulImage) и TObject (TParticulSample).
Также в примере показана обработка событий. Процедуры-обработчики для последних могут находится как на "несущей" форме, так и "внутри" объектов. Обработка событий идентична обработке перечислений (Enum): создаётся список-"перевод" на русский всех возможных процедур-обработчиков и выдаётся в виде списка, из которого пользователь выбирает нужную. Поскольку процедуры нельзя сравнивать (if OnEnter = SelfEnter then ...), то текущие процедуры отслеживаются путём присвоения их русских имён специальным полям в объекте (например, поля StrEnter, StrExit, StrMouseMove в TParticulEdit).
Также в примере показано, как обрабатывать данные типа TBitmap через свойство Handle.
Создание таблицы пользовательской базы данных
Для этого служит операция по кнопке NewT.Работа платформы состоит в следующем, определяется текущая категория информации, которая занесена в свойство Tag в виде числового выражения ссылки на структуру категории информации TInfoCategory:
wTabSheet := FPageControl.ActivePage; wpTInfoCategory := pTInfoCategory(Pointer(wTabSheet.Tag)); В глобальные переменные заносятся соответствующие сведения: apDbType := wpTInfoCategory.sTFbDbType; apDbTypeS := wpTInfoCategory.sEnumName; Создается диалог формирования структуры таблицы и в него передается информация о категории информации, для которой нужно создать таблицу: if TbDlgFr = nil then TbDlgFr := TTbDlgFr.Create(nil); try TbDlgFr.DbInterface := FDbInterface; TbDlgFr.ppTInfoCategory := wpTInfoCategory; TbDlgFr.ShowModal; finally FreeAndNil(TbDlgFr); end;
Если после выхода из этого диалога имеется ненулевая ссылка на буферную структуру FDbInterface.N_pTTableInfo, то производится как обновление отображения главной формы, так и обновление системной базы данных в процедуре Update_Server(). Разумеется, на SQL сервере создается соответствующая таблица пользователя.
Суть обновления системной базы данных состоит в том, что в таблицу T_Tables заносятся сведения о вновь созданной таблице, а в таблицу T_Fields – информация о ее полях.
Создании серверной части обработки документа
Как было отмечено ранее, обработка HTTP запроса может осуществляться либо CGI-приложениями, либо Java-сервлетами. Возможен и вариант написания ASP-страниц. Но в этом случае передача данных возможна только методом "GET" через строку запроса. Хотя, обработка HTTP запроса ASP-страниц работает более эффективнее, чем CGI-приложением. Однако, на мой взгляд, без разницы, как обрабатывать, а важнее решить вопрос - как построить программму обработки, а не какими средствами.Если из предыдущей главы мы рассмотрели варианты формирования XML-документ, то задача серверного приложения обратная - разбор XML-документов. Ниже представлена часть программы, осуществляющей разбор xml-документа:
procedure Tthread1.DataParser(Sender: Tobject); var r,FNode : IXMLDOMElement; // объявление объектов DOMElement Str,Filename : String; parm : String; CoDocXML, CoDocXSL, CoDocResult : CoDomDocument ; // объявление сокласса и XMLDoc, XSLDoc, ResultDoc : DomDocument ; // объекта XMLDomDocument // HttpStr : String; - глобальная переменная, содержащая строку HTTP запроса Begin XMLDoc:=coDocXML.Create; // создание документа XMLDoc XMLDoc.Set_async(false); // установка синхронного режима обрабработки XMLDoc.LoadXML(HttpStr); // загрузка DOM документа из строки HttpStr r:=Doc.Get_documentElement; // получение адреса корневого элемента FNode:= r.SelectSingleNode("//TypeDocument"); // получение значения элемента
Вся изюминка разбора заключается в применении XSL-шаблона, который сформирован для каждого типа документа индивидуально. Результатом разбора является строка SQL-запроса. Впоследствие выполнение сформированной строки SQL-запроса осуществит необходимые изменения данных в СУБД.
Приимущество использования разбора через щаблон еще и в том, что получается некая гибкость данных, и получается полная независимость работы алгоритма от программного кода. Ниже приведен используемый для обработки документа типа ORDER текст XSL-шаблона:
<xsl:stylesheet xmlns:xsl="http://www.w3.org/TR/WD-xsl"> <xsl:template match="/"> <xsl:for-each select="//header"> INSERT into TABREG ( FROM, TO, TYPEDOC,body) VALUES( ' <xsl:value-of select="from" />' ,' <xsl:value-of select="to" />','<xsl:value-of select="TypeDocument/@id" />' ) xsl:for-each> <xsl:for-each select="//item"> INSERT into GOODS ( invoiceNumber, name, price, quality) VALUES( ' :num', '<xsl:value-of select="name" />' , '<xsl:value-of select="price" />', '<xsl:value-of select="quality" /> ' ) xsl:for-each> xsl:template> xsl:stylesheet>
Поясняя вышеприведенный пример, надо отметить, что использование пары тагов и носит формальный характер, т.к. после разбора в результирующем XML-документе формально должен присутствовать хотябы один узел. Метод ResultDoc.text присваивает текстовае значение полученного в ходе разбора XML-документа ResultDoc. В этом случае значением является все то, что обрамлено пары тегов и , т.е. сформированный нами SQL-запрос.
Другой особенностью написания программы надо отметить возможность использования SQL-параметра :num. Использование параметра позволяет упростить текст xsl-шаблона. Определение значение соответствующих элементов узлов XML-документа определякется первоночально выбора по имени соответствующего узла, например:
FNode:= r.SelectSingleNode("//InvoiceNumber"); // поиск элемента >InvoiceNumber> и далее использование свойства text: parm:= FNode.text; // и получение значения элемента >InvoiceNumber>
Список использованной литературы.
Алексей Павлов
Специально для
Moscow Power Engineering Institute (Technical University)
Faculty of Nuclear Power Plants
21.10.02
Скачать (886 K)
var StartupInfo: TStartupInfo; ProcessInformation: TProcessInformation;
//… var StartupInfo: TStartupInfo; ProcessInformation: TProcessInformation; begin GetStartupInfo(StartupInfo); with StartupInfo do begin wShowWindow := SW_HIDE; //не показывать окно dwFlags := STARTF_USESHOWWINDOW; end; // для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?' Win32Check(CreateProcess(nil, 'command.com /c grep.exe ? > MyStdOut.txt', nil, nil, FALSE, CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcessInformation)); // ждем пока наш процесс отработает WaitForSingleObject(ProcInfo.hProcess, INFINITE); Win32Check(CloseHandle(ProcInfo.hProcess); end;//… var ProcInfo: TProcessInformation; StartupInfo: TStartupInfo; hOut, hOutDup: THandle; begin // Создаем файл в который и будем переназначать StdOut // Например, с такими настройками, вы можете их изменить под свои нужды hOut := CreateFile('MyStdOut.txt', GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if (hOut = INVALID_HANDLE_VALUE) then RaiseLastWin32Error; А вот в этом месте и происходит все самое важное!!!
Необходимо сделать рукоятку нашего файла НАСЛЕДУЕМОЙ, что и делаем… Win32Check(DuplicateHandle(GetCurrentProcess, hOut, GetCurrentProcess, @hOutDup, 0, TRUE, DUPLICATE_SAME_ACCESS)); Небольшое замечание
Следует отметить, что если вы пишите прогу ТОЛЬКО под NT/2000, то сделать рукоятку наследуемой можно проще: Win32Check(SetHandleInformation (hOut, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT); и не надо будет заводить дубликат рукоятки hOutDup
// эта рукоятка нам уже не нужна, хотя вы можете ее использовать для своих целей Win32Check(CloseHandle(hOut)); GetStartupInfo(StartupInfo); with StartupInfo do begin wShowWindow := SW_HIDE; // не показывать окно dwFlags := dwFlags or STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; hStdOutput := hOutDup; // присваиваем рукоятку на свой файл end; Для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?'
Вызов CreateProcess с флагом bInheritHandles = TRUE !!! Win32Check(CreateProcess(nil, 'grep.exe ?', nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcInfo)); // ждем пока наш процесс отработает WaitForSingleObject(ProcInfo.hProcess, INFINITE); Win32Check(CloseHandle(ProcInfo.hProcess)); //если вы больше ничего не хотите делать с файлом, в который перенаправили StdOut, то закроем его Win32Check(CloseHandle(hOutDup)); end;
Этот способ мне показал Юрий Зотов (поместив его в разделе "
Ссылки
Стандартные средства
Как известно, компонент TTimer основан на User таймерах, предоставляемых Win32API. Это просто VCL-оболочка, удобная для использования "на форме" системных таймеров данного типа. Для их работы требуется окно, поскольку программа получает извещение о срабатывании таймера посредством сообщения WM_TIMER. Без участия VCL для работы с ними необходим обработчик сообщения WM_TIMER и функции API:CreateTimer SetTimer KillTimer
Да чем же они плохи, эти User таймеры? А вот чем!
Как известно, сообщения в Win32 обрабатываются в следующем порядке очередности:
Таким образом, сообщение WM_TIMER имеет наименьший приоритет и принимается только когда в очереди потока нет других сообщений. Это значит, что своевременному получению "тика" от User таймера может помешать как длительная обработка синхронных и асинхронных сообщений, так и реакция на интенсивный ввод пользователя, и даже активная перерисовка окон.
Кроме того, повторные сообщения WM_TIMER от того же таймера уничтожаются, если в очереди еще есть необработанное такое же. Все это приводит к потере тиков таймера, в результате программа получает меньше вызовов обработчика таймера на заданном интервале, чем рассчитывал программист.
Нельзя сделать так, чтобы моменты срабатывания были привязаны к системному времени (были синхронны с ним), т.е. чтобы таймер тикал в определенные часы, минуты, секунды. Он обязательно будет "уплывать".
О срабатывании таймера User уведомляется только один поток (тот, который вызвал SetTimer), поэтому невозможно пробудить по таймеру сразу несколько потоков.
Дискретность временного интервала оставляет желать лучшего. В Win9x она составляет 55 мс. Но даже в NT интервал квантуется не менее чем по 10 мс.
Stateful и stateless объекты
Как и обычные COM объекты, MTS объекты могут поддерживать свое внутренне сoстояние во время обращения к ним со стороны множества клиентов. Такие компоненты называют stateful. Но с другой стороны, MTS objects могут быть неустойчивыми (stateless), что означает, что объект не сохраняет свое внутреннее состояние (определяемое глобальными перемененными или полями в самом объекте) между обращениями к нему со стороны клиента. Напомним, что только Single модель гарантирует то, что компонент будет сохранять свое состояние между вызовами клиента. Т.е. только в этом случае вы можете использовать для доступа к базам данных компоненты Delphi, просто помещая их на модуль данных.Следует иметь в виду, что такая модель работает значительно медленнее, и stateless объекты являются предпочтительнее.
При использовании любой потоковой модели значения локальных переменных не будут изменяться другими потоками (thread) во время их взаимодействия компонента с клиентом. Эту возможность и следует использовать, чтобы реализовать stateful свойство компонента. Например, для при работе с базами данных вы должны динамически создавать компоненты для доступа к ним ( TQuery, TADOQuery и т.д.) как локальные переменные в ваших методах, например:
| function TMastCon.GetLZString (const RecID: Integer; const ConnectionString: WideString): String; var dsGetBlob: TADODataset; begin Result := ''; // Initialize string result to blank dsGetBlob := TADODataset.Create(nil); {Create TADODataset dynamically} try { Assign the ConnectionString w/c points to the DB } dsGetBlob.ConnectionString := ConnectionString; dsGetBlob.CommandText := 'select DocImage, RecID from _userblobs '+ 'where (RecID = :RecID) and (DocType=''LZ'')'; dsGetBlob.Parameters[0].Value := RecID; . . . . . . finally dsGetBlob.Free; //Release memory allocated to TADODataset end; end; |
В этом случае каждый поток (thread) будет использовать свой собственный локальный компонент ADODataset и они не будет мешать друг другу. А вот для уменьшения количества соединений к базе данных, можно использовать глобальный компонент TADOConnection (естественно, если все нити будут использовать одну и ту же БД с одними и теми же правами доступа). ет, что читатель легко сможет сделать соответствующие изменения в коде.
| рбань С.В., дата публикации 23 декабря 2002г. |
Вообще - я программист молодой, стаж - всего 2 года. И я никак не ожидал, что в век GDI мне придется возится с консолью... Ан нет, пришлось.
Начал писать "движок" для собственного сайта. А именно - "Apache 1.x shared module" (dll - линкуется к Апачу и обрабатывает определенные адреса).
Написал. Всего три сотни строк. НО умеет кучу всяких полезностей, типа вставлять на страницы данные из файлов (файл в файл), строки и, главное, данные из БД. Все это прекрасно. НО не умеет вставлять результаты работы других файлов (типа как CGI). Ну, думаю, надо сделать.
Ага, а как? Вот тут то все и началось...
Итак,
ЗАДАЧА: запустить процесс (некий файл), передать ему команды и получить от него результаты работы. Вставить полученные результаты на страницу сайта.
Причем в целях совместимости механизмы передачи данных ДОЛЖНЫ быть стандартными - StdIn, StdOut, StdErr. Поискал на КД. Нашел вот такую штуку:
Хорошая статья, но мне-то НЕ в ФАЙЛ, а в ПРОГРАММУ надо!
ми :-)). Кому надо - тот сам вставит. (Вот так и рождается "кривой" код. Типа сейчас лень, потом добавлю... Ага... Через час уже забудешь!!!) В общем - перехожу таки к технике дела.
Для передачи данных используются "безымянные" (Anonymus) "каналы" (Pipes). Чтобы заставить программу писать в (читать из) канал (а) - просто подменяем соответствующие Std(In, Out, Err). Программа и знать не будет, что ее данные уходят в "трубу" а не на реальную консоль.
При создании каналов есть одна ВАЖНАЯ особенность. Создаем-то мы их в своем процессе (Parent) а использовать будем и в дочернем. (Учтите! дочерний процесс НЕ будет знать, что использует КАНАЛ! НО будет его использовать...). Так, вот, чтобы дочерний процесс мог нормально работать - хэндлы канала должны быть НАСЛЕДУЕМЫМИ.
Чтобы это обеспечить - надо правильно заполнить структуру SECURITY_ATTRIBUTES используемую при вызове CreatePipe:
| New(FsaAttr); FsaAttr.nLength:=SizeOf(SECURITY_ATTRIBUTES); FsaAttr.bInheritHandle:=True; FsaAttr.lpSecurityDescriptor:=Nil; |
Заполнили? Молодцы! Теперь создаем каналы (я делаю только два, StdErr мне не нужен):
| If not CreatePipe(FChildStdoutRd, FChildStdoutWr, FsaAttr, 0) Then //Создаем "читальный" Pipe raise ECreatePipeErr.CreateRes(@sCreatePipeMsg) Else If not CreatePipe(FChildStdinRd, FChildStdinWr, FsaAttr, 0) Then //Создаем "писальный" Pipe raise ECreatePipeErr.CreateRes(@sCreatePipeMsg) |
Есть еще одна тонкость. У нас Все созданные хэндлы наследуемые! А дочернему процессу понадобятся только два... Поэтому:
| //Делаем НЕ наследуемые дубликаты //Это нужно, чтобы не тащить лишние хэндлы в дочерний процесс... If not DuplicateHandle(GetCurrentProcess(), FChildStdoutRd, GetCurrentProcess(), @Tmp1, 0, False, DUPLICATE_SAME_ACCESS) Then raise EDuplicateHandleErr.CreateRes(@sDuplicateHandleMsg) Else If not DuplicateHandle(GetCurrentProcess(), FChildStdinWr, GetCurrentProcess(), @Tmp2, 0, False, DUPLICATE_SAME_ACCESS) Then raise EDuplicateHandleErr.CreateRes(@sDuplicateHandleMsg) |
| CloseHandle(FChildStdoutRd);//Закроем наследуемый вариант "Читального" хэндла CloseHandle(FChildStdinWr); //Закроем наследуемый вариант "Писального" хэндла FChildStdoutRd:=Tmp1; //И воткнем их места НЕ наследуемые дубликаты FChildStdinWr:=Tmp2; //И воткнем их места НЕ наследуемые дубликаты |
| If not CreateChildProcess(ExeName, CommadLine, FChildStdinRd, FChildStdoutWr) Then //Наконец-то! Создаем дочерний процесс! raise ECreateChildProcessErr.CreateRes(@sCreateChildProcessMsg) |
| //************************************************************************* function TChildProc.CreateChildProcess(ExeName, CommadLine: String; StdIn, StdOut: THandle): Boolean; Var piProcInfo: TProcessInformation; siStartInfo: TStartupInfo; begin // Set up members of STARTUPINFO structure. ZeroMemory(@siStartInfo, SizeOf(TStartupInfo)); siStartInfo.cb:=SizeOf(TStartupInfo); siStartInfo.hStdInput:=StdIn; siStartInfo.hStdOutput:=StdOut; siStartInfo.dwFlags:=STARTF_USESTDHANDLES; // Create the child process. Result:=CreateProcess(Nil, PChar(ExeName+' '+CommadLine), // command line Nil, // process security attributes Nil, // primary thread security attributes TRUE, // handles are inherited 0, // creation flags Nil, // use parent's environment Nil, // use parent's current directory siStartInfo, // STARTUPINFO pointer piProcInfo); // receives PROCESS_INFORMATION end; //************************************************************************* |
Самые умные (то есть те, кто ухитрился дочитать до этого места :-))) спросят:
- Ну, создали мы процесс и что дальше?
А дальше - мы можем с ентим процессом общаться! Например вот так:
| //************************************************************************* function TChildProc.WriteToChild(Data: String; Timeout: Integer=1000): Boolean; Var dwWritten, BufSize: DWORD; chBuf: PChar; begin //Обратите внимание на Chr($0D)+Chr($0A)!!! Без них - будет работать с ошибками //На досуге - подумайте почему... //Для тех, кому думать лень - подскажу - это пара символов конца строки. //(вообще-то можно обойтись одним, но так надежнее, программы-то бывают разные) chBuf:=PChar(Data+Chr($0D)+Chr($0A)); BufSize:=Length(chBuf); Result:=WriteFile(FChildStdinWr, chBuf^, BufSize, dwWritten, Nil); Result:=Result and (BufSize = dwWritten); end; //************************************************************************* |
Читать - несколько сложнее. Нам же не надо вешать всю нашу программу только потому, что процесс не желает нам ничего сообщать??? А ReadFile - функция синхронная и висит - пока не прочитает! Если заранее известно, чего и сколько ДОЛЖЕН выдать процесс, то еще ничего... А если нет?
А если нет - делаем хитрый финт ушами :-) Есть у Мелко-Мягких такая ф-ия PeekNamedPipe. Не покупайтесь, на то, что она "Named" - фигня! Она прекрасно работает а анонимными пайпами! (кто не верит - можете почитать хелп)
Поэтому делаем так:
| //************************************************************************* function TChildProc.ReadStrFromChild(Timeout: Integer): String; Var i: Integer; dwRead, BufSize, DesBufSize: DWORD; chBuf: PChar; Res: Boolean; begin Try BufSize:=0; New(chBuf); Repeat For i:=0 to 9 do begin Res:=PeekNamedPipe(FChildStdoutRd, nil, 0, nil, @DesBufSize, nil); Res:=Res and (DesBufSize > 0); If Res Then Break; Sleep(Round(Timeout/10)); end; If Res Then begin If DesBufSize > BufSize Then begin FreeMem(chBuf); GetMem(chBuf, DesBufSize); BufSize:=DesBufSize; end; Res:=ReadFile(FChildStdoutRd, chBuf^, BufSize, dwRead, Nil); Result:=Result+LeftStr(chBuf, dwRead); end; Until not Res; Except Result:='Read Err'; End; end; //************************************************************************* |
Если честно - с format'ом я не прверял - а вот help c парметрами и "net use" прошли на ура! Так что пришлось резко думать, как ограничить список разрешенных для запуска программ....
В общем, кому лень разбираться - вот вам исходники модуля с готовым классом. А вот пример его использования:
| /************************************************************************* With TChildProc.Create(ReadIni(TagParams.Values['file'], FPage), TagParams.Values['cmd']) do Try WriteToChild(TagParams.Text); ReplaceText:=ReadStrFromChild; Finally Free; End; //************************************************************************* |
Скачать :
Свойства COM компонента
Получение свойств компонента производится аналогичным образом и в дополнительных комментариях не нуждается.| function GetComponentProperties(ApplicationName, ComponentName: String; Properties: Tstrings): boolean; var MainCatalog : ICOMAdminCatalog; Apps : ICatalogCollection; App : ICatalogObject; Comps : ICatalogCollection; comp : ICatalogObject; props : ICatalogCollection; Prop : ICatalogObject; Appscount : integer; i,j,k : integer; compsCount : integer; propsCount : integer; propValue : Olevariant; stringPropValue : string; begin try MainCatalog := CoCOMAdminCatalog.Create; Apps := MainCatalog.GetCollection('Applications') as ICatalogCollection; Apps.Populate; Appscount := Apps.Count; for i := 0 to AppsCount -1 do begin App := ICatalogObject(Apps.Item[i]); if App.Name = ApplicationName then begin comps := ICatalogCollection(Apps.GetCollection('Components', app.Key)); comps.Populate; compsCount := comps.Count; for j := 0 to compsCount - 1 do begin comp := ICatalogObject(Comps.Item[j]); if comp.Name = ComponentName then begin props :=ICatalogCollection(comps.GetCollection('PropertyInfo',comp.Key)); props.Populate; propsCount := Props.Count; Properties.Text :=''; for k := 0 to propsCount-1 do begin prop := ICatalogObject(Props.Item [k]); propValue := (Comp.Value[prop.Name]); case VarType (PropValue) of varBoolean : if propValue = true then stringPropvalue := 'Y' else stringPropvalue := 'N'; else stringPropValue := string(PropValue); end; if prop.name = 'Transaction' then case integer(PropValue) of COMAdminTransactionIgnored : stringPropValue := 'Ignored'; COMAdminTransactionNone : stringPropValue := 'None '; COMAdminTransactionSupported : stringPropValue := 'Supported'; COMAdminTransactionRequired : stringPropValue := 'Required '; COMAdminTransactionRequiresNew : stringPropValue :='Requires New'; end; if prop.name = 'ThreadingModel' then case integer(PropValue) of COMAdminThreadingModelApartment :stringPropValue := 'Apartment'; COMAdminThreadingModelFree :stringPropValue := 'Free'; COMAdminThreadingModelMain :stringPropValue := 'Main'; COMAdminThreadingModelBoth :stringPropValue := 'Both'; COMAdminThreadingModelNeutral :stringPropValue := 'Neutral'; COMAdminThreadingModelNotSpecified :stringPropValue := 'Not Specified'; end; if prop.name = 'Synchronization' then case integer(PropValue) of COMAdminSynchronizationIgnored :stringPropValue := 'Ignored'; COMAdminSynchronizationNone :stringPropValue := 'None'; COMAdminSynchronizationSupported :stringPropValue := 'Supported'; COMAdminSynchronizationRequired :stringPropValue := 'Required'; COMAdminSynchronizationRequiresNew :stringPropValue := 'Requires New'; end; Properties.Add(prop.name + ' = '+ stringPropValue); end; end end end end; result := true; except result := false end end; |
| function GetApplicationProperties(ApplicationName: String; Properties: TStrings): boolean; var MainCat : ICOMAdminCatalog; Apps : ICatalogCollection; App : ICatalogObject; props : ICatalogCollection; Prop : ICatalogObject; Appscount : integer; i,j : integer; propsCount : integer; propValue : Olevariant; stringPropValue : string; begin try MainCat := CoCOMAdminCatalog.Create; Apps := MainCat.GetCollection('Applications') as ICatalogCollection; Apps.Populate; Appscount := Apps.Count; for i := 0 to AppsCount -1 do begin App := ICatalogObject(Apps.Item[i]); if App.Name = ApplicationName then begin //show properties props := ICatalogCollection(Apps.GetCollection( 'PropertyInfo',App.Key)); props.Populate; propsCount := Props.Count; Properties.text :=''; for j := 0 to propsCount-1 do begin prop := ICatalogObject(Props.Item [j]); if not prop.IsPropertyWriteOnly then // you can't read it! begin propValue := (App.Value[prop.Name]); //Get property case VarType (PropValue) of varBoolean : // for Boolean properties if propValue = true then stringPropvalue := 'Y' else stringPropvalue := 'N'; else stringPropValue := string(PropValue); end; // Enumerated properties if prop.name = 'Authentication' then case integer(PropValue) of COMAdminAuthenticationDefault : stringPropvalue := 'Default'; COMAdminAuthenticationNone : stringPropvalue := 'None'; COMAdminAuthenticationConnect : stringPropvalue := 'Connect'; COMAdminAuthenticationCall : stringPropvalue := 'Call'; COMAdminAuthenticationPacket : stringPropvalue := 'Packet'; COMAdminAuthenticationIntegrity : stringPropvalue := 'Packet Integrity'; COMAdminAuthenticationPrivacy : stringPropvalue := 'Packet Privacy'; end; if prop.name = 'ImpersonationLevel' then case integer(PropValue) of COMAdminImpersonationAnonymous : stringPropvalue := 'Anonymous'; COMAdminImpersonationIdentify : stringPropvalue := 'Identify'; COMAdminImpersonationImpersonate : stringPropvalue := 'Impersonate'; COMAdminImpersonationDelegate : stringPropvalue := 'Delegate'; end; Properties.Add(prop.name + ' = '+ stringPropValue); // Add to list end end; end end; result := true; except result := false; end end; |
| Раздел Подземелье Магов | н, дата публикации 18 июля 2001г. |
Мысль о хорошем таймере давно волнует умы программистов. Сразу оговорюсь, что речь не идет о прецизионном, "высокочастотном" иструменте отсчета интервалов времени, с дискретностью 1 мс и менее, как иногда хочется. Для этого существуют иные методы и/или иные операционные системы.
Здесь же будет построен просто надежный таймер общего назначения, который "тикнет" вовремя, во что бы то ни стало. Реализация в пределах стандартных возможностей Win32API, т.е. ничего "военного". Плюс одна интересная идея, заимствованная из мира Unix.
Текст монитора приведен ниже
Текст с высоты птичьего полета или Регулярные выражения
| Раздел Подземелье Магов |
"Look for a white shirt and a white apron," said the head which had
been put together, speaking in a rather faint voice. "I'm the cook."
L. Frank Baum, The Emerald City of Oz
При решении прикладных задач, полезно рассматривать их с высоты "птичьего полета". Многие знают что это может существенно ускорить разработку, но не многие этим пользуются.
Разница в посимвольной обработке строк и обработке с помощью регулярных выражений в том, что в первом случае Вы думаете прежде всего как достичь цели, а во втором - а какая цель Вам собственно нужна ? %-) Кроме того, посимвольные алгоритмы трудно модифицировать, не говоря уж о том, что любая модификация сопровождается перекомпиляцией приложения.
В этой небольшой статье собрано несколько иллюстраций использования регулярных выражений в Delphi.
Прим.
| Детектор лжи |
Предположим, Вам необходимо выманить ;) у пользователя адрес его электронной почты (моральную сторону и маркетинговую обоснованность подобной затеи мы здесь рассматривать не будем).
Идея в том, что если отвергать синтаксически некорректные адреса, то большинству пользователей надоест играть в эту орлянку и они либо откажутся от Вашей программы / уйдут с web-страницы, либо введут синтаксически корректный адрес. А как рядовому юзеру проще всего ввести такой адрес ?.. Правильно ! Проще всего ввести свой реальный e-mail !
Естественно, что вариант с p := Pos ('@', email); if (p > 1) and (p < length (email)) then ... проблемы не решает. Желательно как минимум просмотреть строку на предмет отсутствия некорретных символов а также наличия домена второго (или выше) уровня. Конечно, любой программист напишет такой анализатор... строк этак на *дцать и с перспективой перекомпилировать программу если что-то не впишется в эту проверку.
А теперь забудьте о посимвольной обработке и посмотрите на этот же анализатор, упрятанный в одну строку : if ExecRegExpr ('[\w\d\-\.]+@[\w\d\-]+(\.[\w\d\-]+)+', email) then ... gotcha! ... Регулярные выражения позволяют гибко реализовать достаточно изощренные проверки. Вот, скажем абсолютно корректная проверка на ... римские цифры любой величины (шаблон позаимствован из книги "Mastering Perl"): const Mask1 = '^(?i)M*(D?C{0,3}|C[DM])(L?X{0,3}|X[LC])(V?I{0,3}|I[VX])$'; ... if not ExecRegExpr (Mask1, DBEdit1.Text) then begin ... show error message ... DBEdit1.SetFocus; end;
| Персонального www-робота - каждому ! |
Например вот таким нехитрым способом можно получить курс доллара и дату этого курса программно, не рассматривая рекламные баннеры (да простят меня CityCat и ФинМаркет ;) ).
Бросьте на форму TBitBtn, TLabel и TNMHTTP (TNMHTTP здесь использован исключительно для упрощения примера. Использовать эту гадость в реальной жизни не советую :-E~ ) и вставьте такой код обработки нажатия BitBtn1: procedure TForm1.BitBtn1Click(Sender: TObject); const Template = '(?i)Официальный курс ЦБ по доллару' + '.*Дата\s*Курс\s*Курс пок.\s*Курс прод. [^<\d]*' + '(\d?\d)/(\d?\d)/(\d\d)\s*[\d.]+\s*([\d.]+)'; begin NMHTTP1.Get ('http://win.www.citycat.ru/finance/finmarket/_CBR/'); with TRegExpr.Create do try Expression := Template; if Exec (NMHTTP1.Body) then begin Label1.Caption := Format ('Курс на %s.%s.%s: %s', [Match [2], Match [1], Match [3], Match [4]]); end; finally Free; end; end; В этом примере используется очень мощный механизм backtrack, отличающий NFA (non-deterministic finite state machine) реализацию регулярных выражений от DFA (deterministic finite state machine). В случае с NFA (на базе которого построен и TRegExpr) мы получаем возможность работать с подвыражениями, что и использовано в примере выше для выделения из шаблона элементов даты и собственно курса.
Кстати, здесь уже проявляются и ограничения регулярных выражений (см. ). Решая подбную задачу, я бы предварительно обработал текст: убрал бы незначимые тэги (ИМХО для надержного анализа достаточно оставить только табличные тэги), из оставшихся тэгов убрал бы все модификаторы (size, align и т.п.), убрал бы все переводы строк, а табуляции заменил на пробелы и убрал после этого повторяющиеся пробелы. После этого можно уже написать гораздо более надежное регулярное выражение.
А вот так можно достаточно надежно вынуть из неформализованного текста все Санкт-Петербургские номера телефонов (представленные как '(812)123-4567' или '+7 (812) 12-345-67' и т.д., причем извлечены будут внутригородские части номеров): procedure ExtractPhones (const AText : string; APhones : TStrings); begin with TRegExpr.Create do try Expression := '(\+\d *)?(\((\d+)\) *)?(\d+(-\d*)*)'; if Exec (AText) then REPEAT if Match [3] = '812' then APhones.Add (Match [4]) UNTIL not ExecNext; finally Free; end; end;
| Господин Оформитель |
Вот пример реализации (он не всегда сработает, но ведь 100% распознавание даже теоретически невозможно, да и в такого рода задачах не страшно если что-то не будет найдено. Страшно впустую тратить время на вспомогательные по сути вещи): type TDecorateURLsFlags = ( // Включаемые в видимую часть гипер-ссылки поля durlProto, // Протокол ('ftp://' или 'http://') durlAddr, // IP-адрес или символическое имя домена durlPort, // номер порта (например ':8080') durlPath, // путь (unix-формат) durlBMark, // объект внутри страницы (напрмер '#bookmark') durlParam // параметры запроса (например '?ID=13&User=Pupkin') ); TDecorateURLsFlagSet = set of TDecorateURLsFlags; function DecorateURLs (const AText : string; AFlags : TDecorateURLsFlagSet = [durlAddr, durlPath]) : string; const URLTemplate = '(?i)' // регистро-независимый режим + '(' + '(FTP|HTTP)://' // Протокол + '|www\.)' // Позволяет отловить ссылки указанные без 'http://' + '([\w\d\-]+(\.[\w\d\-]+)+)' // IP-адрес или символическое имя домена + '(:\d\d?\d?\d?\d?)?' // номер порта + '(((/[%+\w\d\-\\\.]*)+)*)' // путь (unix-формат) + '(\?[^\s=&]+=[^\s=&]+(&[^\s=&]+=[^\s=&]+)*)?' // параметры запроса + '(#[\w\d\-%+]+)?'; // объект внутри страницы var PrevPos : integer; s, Proto, Addr, HRef : string; begin Result := ''; PrevPos := 1; with TRegExpr.Create do try Expression := URLTemplate; if Exec (AText) then REPEAT s := ''; if CompareText (Match [1], 'www.') = 0 then begin Proto := 'http://'; Addr := Match [1] + Match [3]; HRef := Proto + Match [0]; end else begin Proto := Match [1]; Addr := Match [3]; HRef := Match [0]; end; if durlProto in AFlags then s := s + Proto; // Match [1] + '://'; if durlAddr in AFlags then s := s + Addr; // Match [2]; if durlPort in AFlags then s := s + Match [5]; if durlPath in AFlags then s := s + Match [6]; if durlParam in AFlags then s := s + Match [9]; if durlBMark in AFlags then s := s + Match [11]; Result := Result + System.Copy (AText, PrevPos, MatchPos [0] - PrevPos) + '' + s + ''; PrevPos := MatchPos [0] + MatchLen [0]; UNTIL not ExecNext; Result := Result + System.Copy (AText, PrevPos, MaxInt); // Tail finally Free; end; end; { of function DecorateURLs -------------------------------} Обратите внимание, что в приведенном выше примере Вы имеете возможность легко выделять из URL протокол, домен, путь и параметры запроса (см. параметр AFlags).
| Панацея ? |
Дело в том, что Перл - интерпретирующий язык. Основное следствие из этого - чем меньше операторов выполняется, тем быстрее (как правило) работает программа. В большистве случаев регулярное выражение отработает быстрее чем самый элементарный посимвольный анализ строки.
Поэтому, не кажется диким реализация функции Trim как выражения '^\s*(\S*)\s*$'.
Думаю, не надо объяснять насколько это глупо в истинно компилируемом Паскале. Так что, если анализируемая строка имеет простую структуру - напишите элементарный и очень быстрый цикл по ее разбору и не связывайтесь с регулярными выражениями.
Кроме того, не рекомендую использовать регулярные выражения там, где нужен полноценный парсер. Если, например, Вам нужно разобрать на теги HTML - поищите для этого более подходящий инструмент !
Если же искомая или проверяемая строка имеет сложную структуру, если эта структура может меняться, тогда это наш клиент ;) Если же описание должно меняться без перекомпиляции программы, то серьезной альтернативы регулярным выражениям практически нет.
Успехов !
Да, чуть не забыл, библиотека которая устраняет досадную забывчивость разработчиков Delphi и позволяет использовать в Delphi регулярные выражения без необходимости таскать за собой какие-либо DLL, лежит на
или
.
Андрей Сорокин
Специально для
Теоретические основы изображения кривых Безье
Теорию кривых Безье разработал П. де Кастело в 1959 году и, независимо от него, П. Безье в 1962 году. Для построения кривой Безье N-ого порядка необходимо N+1 точек, две из которых определяют концы кривой, а остальные N-1 называются опорными. В компьютерной графике наибольшее распространение получили квадратичные кривые Безье, строящиеся по трём точкам, и кубические кривые Безье, строящиеся по четырём точкам. Квадратичные кривые Безье используются, например, в шрифтах TrueType при определении контуров символов. API Windows позволяет строить только кубические кривые Безье.Кубические кривые Безье задаются следующей формулой: P(t)=A*(1-t)3+3*B*t*(1-t)2+3*C*(1-t)*t2+3*D*t3, (1) где A - начало кривой, D - её конец, а B и C - первая и вторая опорные точки. Прямая AB является касательной к кривой в точке A, прямая CD - в точке D. Параметр t изменяется от 0 до 1. При t=0 P(t)=A, при t=1 P(t)=D
Одним из важнейших свойств кривой Безье является её делимость. Если кривую разделить на две кривых в точке t=0.5, каждая из полученных кривых также будет являться кривой Безье. На этом свойстве основывается алгоритм рисования кривых Безье: если кривая может быть достаточно точно аппроксимирована прямой, рисуется отрезок прямой, если нет - она разбивается на две кривых Безье, к каждой из которых вновь применяется этот алгоритм.
В Windows поддерживается два типа кривых: кубические кривые Безье и эллиптические дуги. В Windows 9x/Me дуги рисуются независимо от кривых Безье. В Windows NT/2000/XP дуги аппроксимируются кривыми Безье.
Для рисования кривых Безье используются функции PolyBezier, PolyBezierTo и PolyDraw.
В некоторых случаях удобно строить кривую Безье не по опорным точкам, а по точкам, через которые она должна пройти. Пусть кривая начинается в точке A, при t=1/3 проходит через точку B`, при t=2/3 - через точку C`, и заканчивается в точке D. Подставляя эти точки в уравнение (1), получаем систему, связывающую B` и C` с B и C. Решая систему, получаем:
B=(-5*A+18*B`-9*C`+2*D)/6 (2) C=(2*A-9*B`+18*C`-5*D)/6
Из этих уравнений, в частности, следует, что для любых четырёх точек плоскости существует, и притом единственная, кривая Безье, которая начинается в первой точке, проходит при t=1/3 через вторую точку, при t=2/3 - через третью и завершается в четвёртой точке. Аналогичным образом можно вычислить опорные точки для кривой, которая должна проходить через заданные точки при других значениях t.
Тестирование
Разумеется, в мире нет ничего абсолютного. А тем более когда дело касается столь нереалтаймовой системы как Уиндоус. Впрочем, в случае real-time OS вопрос о таймерах вообще бы не стоял. А в наших условиях вполне может найтись в системе какой-нибудь хулиганский поток с высоким приоритетом (выше или равным нашему), который наглым образом будет отбирать управление на длительное время (больше длительности внутреннего цикла таймерного менеджера - 10 мс). И тогда наш таймер будет пропускать "тики" на коротких заданных интервалах и увеличивать погрешность на длинных. Это происходит в том случае, если кто-то работает не по правилам, либо производительности процессора не хватает для работы системы.В целях проверки и демонстрации функционирования таймерного менеджера, а также сравнительного анализа со стандартным таймером была разработана демо-программа ().
Сравнивались: компонент TTimer, два интервальных таймера с разными способами уведомления (сообщение окну и асинхронный вызов), один синхронизированный таймер. Подсчитывалось количество срабатываний. Каждый факт срабатывания таймера записывался в журнал (TMemo), что также играло роль полезной нагрузки в работе приложения (попросту отъедание процессорного времени). Дополнительная нагрузка по инициативе пользователя эмулировалась задержкой (sleep) в обработчике событи OnClick кнопки. Одновременно контролировалась загрузка процессора по показаниям Windows NT Task Manager.
Проведенные исследования показали (см. таблицу), что интервальный таймер ведет себя почти идеально от 100 мс и достаточно хорошо на более мелких интервалах, тогда как стандартный таймер на коротких интервалах, а особенно под нагрузкой совсем сдает позиции. На интервале 10 мс интенсивная обработка извещений от таймеров (обновление контролов, особенно TMemo) приводит к 100% загрузке процессора. Синхронизированный таймер (FixedTimer), заряженный на минимальный интервал 1 с, всегда давал точное число тиков, причем срабатывал в начале секунды с небольшим разбросом.
От способа уведомления количество полученных тиков не зависело. При большой нагрузке и высокой частоте приложение могло получать уведомления PostMessage неравномерно (пачками накопленных в очереди сообщений), но общее число выдерживалось, насколько это возможно.
Результаты приведены для следующей конфигурации: Cyrix 6x86PR233/64M/WinNT4. Измерения проводились также на платформе Win98SE, где IntervalTimer показал примерно те же результаты, а TTimer еще более худшие.
| Нормальные условия | |||||
| 100 | 10000 | 100 | 99 | 100 | 3-12 |
| 100 | 100000 | 1000 | 998 | 1000 | 3-12 |
| 10 | 10000 | 1000 | 659 | 999 | 100 |
| 10 | 100000 | 10000 | 6361 | 9991 | 100 |
| 15 | 10000 | 667 | 482 | 667 | 44-60 |
| Нагрузка приложения (задержка на 2000 мс) | |||||
| 100 | 10000 | 100 | 79 | 100 | 2-17 |
| 15 | 10000 | 667 | 333 | 667 | 2-100 |
| 10 | 10000 | 1000 | 156 | 999 | 2-100 |
| Внешняя нагрузка (играющий Winamp) | |||||
| 100 | 10000 | 100 | 97 | 100 | 28-51 |
| 15 | 10000 | 667 | 175 | 632 | 100 |
| 10 | 10000 | 1000 | 22 | 894 | 100 |
Специально для
Исходные тексты программ, приложенные к данной статье, распространяются на правах freeware.
Все исходные тексты и откомпилированная DLL собраны в архив .
Тестовая программа (исходные тексты) отдельно в файле
Для интересующихся - сорцы версии на С++ в файле .
Типы данных
Некоторые задачи обеспечения целостности базы данных и адаптации ее к предметной области оказались легко решаемыми посредством ввода специальных структур для хранения в памяти информации о типах данных, причем в них содержатся не только традиционные сведения, такие, как тип поля, ее размер и т.д., но и дополнительная информация, вводимая для повышения удобства работы с ними настройщику и пользователю. К такой информации относится, прежде всего, смысловое наименование типа, понятное для пользователя, не обладающего специальными знаниями в области программирования. Так, например, программисту все ясно, когда он видит обозначение типа как ftInteger, а для пользователя лучше, когда он увидит в качестве обозначения типа фразу «Целое число». Для ряда задач оказалось удобным создать специальный набор структур, предназначенных для хранения информации о типах полей, используемых для связей между таблицами, а также типов полей для хранения данных, выбираемых пользователем из собственных списков, по существу являющихся справочниками небольшого объема. В таких структурах дополнительной информацией являются смысловые названия полей и списков. В связи с этим были введены так называемые группы данных, каждая из которых представляет собой определенный набор типов данных, имеющих общий признак, т.е. описываемых структурой одного и того же типа. Обратим внимание, что фактически все поля, с которыми манипулирует наша платформа, имеют типы, предусмотренные в BDE, и здесь ничего нового нет. Новое понятие групп данных связано с характером той дополнительной информации, которая сопровождает параметры типа поля в указанных структурах. Если эта информация сводится просто к названию типа и нет других особенностей, связанных с полем, имеющим этот тип (например, просто поле имеет тип «Целое число»), то мы будем такие поля относить к базовой группе данных, а во всех остальных случаях – к той или иной группе данных, в зависимости от характера дополнительной информации, которая важна с точки зрения назначения системы. В этих случаях уже неважно, как называется тип по канонам BDE, - эта информация в структуру даже не вводится, так как дополнительная информация, вводимая в структуру, косвенно содержит описание типа. Так, если поле предназначено для хранения информации из списков, то косвенно это означает, что тип поля ftString. Важно еще подчеркнуть, что групп данных априори может быть сколько угодно. В описываемой платформе пока таких групп реализовано четыре.Базовая группа данных Прежде всего, разработчику следует решить, какие типы данных, реализуемые BDE, он собирается использовать в своей платформе. Вряд ли целесообразно организовывать поддержку почти сорока типов, перечисленных в BDE. Следует поддерживать часто используемые типы, такие как ftString, ftInteger, ftFloat, ftDate, ftTime, ftDateTime. Для автоинкрементных полей понадобится тип ftAutoInc. Для работы с текстами, графикой и вообще с бинарными данными нужны ftBlob, ftMemo, и, возможно, ftGraphic. Дальнейшее расширение базовой группы скорее носит узкоспециализированный характер.
Чтобы настройщик и пользователь могли свободно манипулировать выбранным подмножеством типов данных, целесообразно ввести структуру:
| // Структура базового типа данных TFbBaseType = record sType: TFieldType; // идентификация типа BDE sBytes, // количество байтов под данный тип sSize, // размер типа, аналог из BDE sInc: Integer; // признак включения типа в платформу sDescr: ShortString; // краткое описание типа end; |
Ссылочная группа данных Ссылочная группа данных связана с требованием обязательности автоинкрементного поля в каждой таблице базы данных. Под ссылкой на таблицу можно иметь в виду поле целого типа, в котором хранится содержимое автоинкрементного поля той таблицы, на которую создается ссылка (ведущей таблицы). Для работы с ссылочными типами данных введена структура:
| // Структура ссылочного типа данных TFbReferenceType = record sType: TFieldType; sBytes, sSize, sInc: Integer; sDescr: ShortString; spTableInfo: pTTableInfo; end; |
Следящая группа данных Следящая группа данных особых пояснений не требует, т.к. принцип работы с ней в целом аналогичен принципу работы со ссылочной группой. Особенность состоит в том, что в структуру управления, помимо ранее рассмотренного указателя на структуру таблицы, вводится указатель на структуру того поля, на которое создается ссылка (ведущее поле), а тип sType устанавливается равным типу ведущего поля:
| // Структура следящего типа данных TFbLookupType = record sType: TFieldType; sBytes, sSize, sInc: Integer; sDescr: ShortString; spFieldInfo: pTFieldInfo; spTableInfo: pTTableInfo; end; |
Списочная группа данных Простейший список может состоять из значений Да, Нет. Списков аналогичного свойства, содержащих от двух до десятка и более членов, из которых пользователь может выбирать значение, любая предметная область содержит во множестве. Так, очень удобно реализовывать такими списками справочники небольшого объема. Примером может быть справочник частей света из 6 членов: Европа, Азия, Америка, Африка, Австралия и Антарктида. Другой пример - набор специальностей медицинского персонала, и т.д. Структура для работы со списочными типами, по аналогии с остальными, имеет вид:
| // Структура списочного типа данных TFbPickType = record sType: TFieldType; sBytes, sSize, sInc: Integer; sDescr: ShortString; sPickList: TStrings; end; |
Для централизованного управления программным кодом в процессе использования групп данных целесообразно ввести обобщенную структуру. Предвидя это, мы намеренно вводили для всех групп данных схожие структуры для работы с ними в памяти. Сначала введем комбинированный тип для групп данных: TFbTypeGroup = (FldGroup, RefGroup, PicGroup, LUpGroup, NoGroup) соответственно идентифицирующий базовую, ссылочную, списочную и следящую группы. Для полноты в него введен тип NoGroup, не содержащий никакой группы.
Получаем структуру обобщенного (комбинированного) типа данных в виде вариантной записи:
| // Структура комбинированного типа данных TFbCommonType = packed record FbTypeGroup: TFbTypeGroup; case TFbTypeGroup of FldGroup: (FbFld: pTFbBaseType); RefGroup: (FbRef: pTFbReferenceType); PicGroup: (FbPic: pTFbPickType); LUpGroup: (FbLUp: pTFbLookupType); NoGroup: (); end; |
Модернизируем структуру поля, приведенную выше (см. раздел ):
| // Структура поля TFieldInfo = record sFieldAttr: TStrings; // атрибуты поля: { sFieldName - Имя поля } { sMTableName - Имя ведущей таблицы } { sMFieldName - Имя ведущего поля } { sPicDescr - Имя списочного типа } { sFieldCaption - Наименование } { sFieldDescr - Описание } sFieldType: TFieldType; sFieldSize: Integer; sFieldMBytes: Integer; sMTTableInfo : pTTableInfo; // Ссылка на структуру главной таблицы sMTFieldInfo : pTFieldInfo; // Ссылка на структуру главного поля sPickList : TStrings; // Список списочного типа end; |
Приведенные правила позволяют хранить необходимую информацию о типах полей в системной базе данных, а при загрузке приложения создавать в памяти необходимые списки структур TFbCommonType. Это - ключевая задача, которая обеспечивает возможность работать с типами полей в платформе в режиме конфигуратора, а в пользовательском режиме - реализовать ссылки и списки значений.
После такого утомительного экскурса в дебри построения платформы, вернемся к листингу L2, чтобы пояснить как работает диалог с полями-переменными FpTFbCommonType : pTFbCommonType; FTFbTypeGroup : TfbTypeGroup.
В момент передачи диалогу ссылки на интерфейс к базам данных в обработчике Set_FDbInterface производится заполнение списка групп данных TypeGroupCmBox.
При выборе какого-либо конкретного элемента из этого списка по событию TypeGroupCmBoxChange будет заполнен соответствующий список типов данных TypesComboBox, из которого пользователь может выбрать конкретный тип поля, формируемого диалогом.
После открытия диалога формирования поля необходимо выбрать группу данных, а затем из списка типов данных этой группы выбрать конкретное значение типа. Подчеркнем еще раз, что в ссылочной и следящей группах данных информация появляется только при наличии в базе данных таблиц.
При выходе из диалога по кнопке ОК выполняется метод Execute, в котором задаются атрибуты буферной структуры поля FDbInterface.N_pTFieldInfo, созданной до входа в данный дилог.
В заключение раздела, касающегося создания таблицы, приведем листинг диалога, в котором производится формирование списка полей для таблицы. Особенность данного диалога состоит в том, что при входе в него автоматически создается начальная структура поля для автоинкрементного поля.
Листинг L3.
, приведенного в листинге L3.
Траектории
API Windows реализует поддержку специфических объектов, называемых траекториями (path). Траектория представляет собой запись движения пера и состоит из одного или нескольких замкнутых контуров. Каждый контур состоит из отрезков прямых и кривых Безье. Для построения траектории в Windows NT/2000/XP могут быть использованы все графические функции рисования прямых, кривых и замкнутых контуров, а также функции вывода текста (в этом случае замкнутые контуры будут совпадать с контурами символов). В Windows 9x/Me могут быть использованы только функции рисования прямых, ломаных, многоугольников (за исключением PolyDraw и Rectangle), кривых Безье и функций вывода текста. Для создания траектории используются функции BeginPath и EndPath. Все вызовы графических функций, расположенные между BeginPath и EndPath, вместо вывода в контекст устройства будут создавать в нём траекторию.После того как траектория построена, её можно отобразить или преобразовать. Мы не будем здесь перечислять все возможные операции с траекториями, остановимся только на преобразовании траектории в ломаную. Как уже отмечалось выше, все контуры траектории представляют собой набор отрезков прямых и кривых Безье. С другой стороны, при построении кривой Безье она аппроксимируется ломаной. Следовательно, вся траектория может быть аппроксимирована набором отрезков прямой. Функция FlattenPath преобразует кривые Безье, входящие в состав траектории, в ломаные линии. Таким образом, после вызова этой функции траектория будет состоять из отрезков прямой.
Отметим также некоторые другие преобразования траектории, полезные для создания графических редакторов и подобных им программ. Функция PathToRegion позволяет преобразовать траекторию в регион. Это может понадобиться, в частности, при определении, попадает ли курсор мыши в область объекта, представляемого сложной фигурой. Функция WidenPath превращает каждый контур траектории в два контура - внутренний и внешний. Расстояние между ними определяется толщиной текущего пера. Таким образом, траектория как бы утолщается. После преобразования утолщённой траектории в регион можно определять, попадает ли курсор мыши на кривую с учётом погрешности, определяемой толщиной пера.
Поучить информацию о точках текущей траектории можно с помощью функции GetPath. Для каждой точки траектории эта функция возвращает координаты и тип точки (начальная линии, замыкающая точка отрезка, точка кривой Безье, конец контура).
Таким образом, создав траекторию из кривой Безье (BeginPath/PolyBezier/EndPath), мы можем преобразовать эту траекторию в ломаную (FlattenPath), а затем получить координаты узлов этой ломаной (GetPath).
Требования к MTS объектам
В дополнение к обычным требованиям, предъявляемым COM к компонентам, MTS требует, чтобы компоненты находились внутри DLL.Кроме того, существуют следующие требования, которые Мастера Delphi выполняют автоматически:
Удаление поля в пользовательской таблице
Реализуется по кнопке DeleteF главной формы конфигуратора. В данном случае поступают по следующей схеме. Сначала из системной таблицы удаляется информация о выбранном поле в процедуреRemoveFrom_T_Fields(FDbInterface, FpTFieldInfo);
Затем удаляется информация из списка FieldsLBox на главной форме и, наконец, пользуясь методом
FDbInterface.DeleteField(FpTTableInfo.sTableAttr.Values['sTableName'], FpTFieldInfo.sFieldAttr.Values['sFieldName']) удаляют структуру поля в памяти и обновляют структуру таблицы на сервере базы данных. В заключение производится обновление списков типов данных FDbInterface.Update_FbCommonTypeList.
(Продолжение следует)
Скачать пример:
Николай Озниев
Удаление пользовательской таблицы
Реализуется по кнопке DeleteT главной формы конфигуратора. Сначала определяется ссылка на выбранную структуру таблицы через свойство Tag активной страницы объекта FPageControl, а затем вся работа выполняется в процедуре Delete_Table, в которую передается ссылка на структуру удаляемой таблицы.В этой процедуре сначала удаляется информация о таблице из системных таблиц T_Tables и T_Fields с помощью соответствующих SQL-запросов. Затем удаляется из памяти структура поля вызовом специально для этого предназначенного метода интерфейса к базам данных:
FDbInterface.Dispose_pTTableInfo(ApTTableInfo, True, True);
Здесь второй параметр указывает на необходимость удаления списка структур полей, а третий – на необходимость обновления информации о типах. Последнее действие необходимо в связи с тем, что при удалении любой таблицы происходит удаление одной записи в списке ссылочной группы данных и удаление из списка следящей группы данных стольких записей, сколько было полей в удаляемой таблице, не считая автоинкрементного поля.
Установка компонента в пакет
Выполнить эту операцию можно с помощью метода InstallComponent интерфейса ICOMAdminCatalog ComAdminCatalog.InstallComponent('COMTest', 'D:\users\Tranning\COM+\Capital.dll', '',''); где в первый параметр - имя пакета, в который будет устанавливаться компонент, второй - имя компонента (файла) который будет устанавливаться, следующий параметр - имя файла с библиотекой типов (в том случае, если она встроена в главный файл, то его можно опустить) и имя proxy-stub .dll (если не используется, то его так же опускают).Установка MapX в Delphi
После установки дистрибутива MapX на компьютер нужно установить MapX в Delphi. Следующие шаги устанавливают МарХ в Delphi package. Это необходимо сделать только один раз. |
В диалоге Install, установите его в по умолчанию в пакете программ Borland User's Components. Нажмите Yes чтобы перекомпилировать пакет программ (package), затем закройте и сохраните окно Package.
Пиктограмма МарХ должна появиться в Controls palette, в разделе ActiveX.
| type TGsvCustomObjectInspectorGrid = class(TCustomControl) protected property LongTextHintTime: Cardinal; property LongEditHintTime: Cardinal; property AutoSelect: Boolean; property HideReadOnly: Boolean; property OnEnumProperties: TGsvObjectInspectorEnumPropertiesEvent; property OnGetStringValue: TGsvObjectInspectorGetStringValueEvent; property OnSetStringValue: TGsvObjectInspectorSetStringValueEvent; property OnGetIntegerValue: TGsvObjectInspectorGetIntegerValueEvent; property OnSetIntegerValue: TGsvObjectInspectorSetIntegerValueEvent; property OnFillList: TGsvObjectInspectorFillListEvent; property OnShowDialog: TGsvObjectInspectorShowDialogEvent; property OnHelp: TGsvObjectInspectorInfoEvent; property OnHint: TGsvObjectInspectorInfoEvent; public procedure NewObject; procedure Clear; procedure ExpandAll; procedure CollapseAll; end; |
Вначале отметим самые простые свойства и методы:
| TGsvObjectInspectorEnumPropertiesEvent = procedure(Sender: TObject; Index: Integer; out Info: PGsvObjectInspectorPropertyInfo) of object; |
| procedure TForm1.OnEnumProperties(Sender: TObject; Index: Integer; out Info: PGsvObjectInspectorPropertyInfo); begin Info := ObjectManager.PropertyInfo(Index); end; |
| procedure TForm1.OnGetStringValue(Sender: TObject; Info: PGsvObjectInspectorPropertyInfo; out Value: String); begin try Value := ObjectManager.GetStringValue(Info); except on E: Exception do StatusMessage('Error: ' + E.Message); end; end; |
| procedure TForm1.OnHint(Sender: TObject; Info: PGsvObjectInspectorPropertyInfo); begin if Assigned(Info) then StatusBar.SimpleText := Info^.Hint; end; |
При отображении всплывающей подсказки редактирования курсор мыши приобретает вид стрелки вверх и перемещается на область подсказки, чтобы не мешать редактированию. Контролируются подсказки редактирования свойством LongEditHintTime аналогично LongTextHintTime.
Вопросы реализации.
Вот собственно то, что я хотел сказать о технологии "многозвенного программирования". Теперь практическая часть. Как можно реализовать такую технологию? Один из наиболее используемых вариантов - это встраивание в программу интерпретатора проблемно-ориентированного языка. Встраивание компилятора я встречал значительно реже. В своей программистской практике я использовал оба варианта. Достоинства интерпретатора очевидны, но также очевидны и недостатки. Общий принцип состоит в том, что интерпретатор либо каждый раз интерпретирует исходное представление программы на проблемно-ориентированном языке, либо порождает промежуточный код, исполняемый некоторой виртуальной машиной. Примеры - пакет Microsoft Office с языком VB for Applications, реализация языка Java. Сюда же относятся все скриптовые языки. Если требуется межплатформенная совместимость, то интерпретаторы, вероятно, будут лучшим вариантом. Если же более важны соображения эффективности, то компиляция оказывается более предпочтительным выбором. Общий принцип - берем описание задачи на проблемно-ориентированном языке, генерируем соответствующий код на некотором универсальном языке, компилируем его и выполняем.В этом разделе статьи я расскажу о втором варианте - использование компилятора, а конкретно, dcc32.exe из поставки Delphi (хотя можно использовать любой другой быстрый и качественный компилятор для любого другого подходящего языка).
Далее я рассмотрю этапы, которые нужно сделать, чтобы воплотить замыслы технолога. Конкретности реализации демонстрируется на примере небольшой библиотеки, которую прилагаю к статье (называется она DccUsing) и крошечного проекта под незатейливым именем DccExamples.
"Вшивание" информации в растровые рисунки.
| Раздел Подземелье Магов |
В данной статье демонстрируется программа, позволяющая сохранять текстовую информацию в растровые рисунки. Суть программы состоит в следующем: берется текстовый файл и набор файлов рисунков. Далее выбирается подходящий рисунок и на его основе создается второй рисунок, несколько измененный. Причем степень изменения зависит от количества "вшиваемых" данных. При небольшом количестве информации отличить рисунки практически невозможно. А получить обратно текстовую информацию можно только лишь совместив эти два рисунка, а также имея библиотеку, реализующую алгоритм "склеивания" этих рисунков.
Так выглядит программа в "рабочем" состоянии. А текст я взял из какого-то файла, валявшегося у меня под рукой.
Введение и библиография
В журнале (№9 за 2002 г.) была опубликована статья Вячеслава Ермолаева "Использование template-классов при импортировании функций из DLL".Уважаемый ет для решения этой задачи использовать механизм шаблонов (templates) языка С++. Это огромный шаг вперёд по сравнению с рутинным кодированием, но на мой взгляд, не идеальное решение, которому присущи некоторые недостатки:
Технология.
Хотя в названии статьи тема выглядит довольно узко, я хотел бы рассказать не только об использовании dcc32, но и о технологии, которой я дал условное название "многозвенное программирование", хотя вынести это название в заголовок статьи мне показалось неправильным. Какой смысл я вкладываю в термин "многозвенное программирование"? Начну издалека. Работу над более или менее большими программами можно разделить на два крупных этапа. Первый этап - это собственно разработка, которая включает формулировку технического задания, увязку требований заказчика, проектную фазу, итеративное уточнение структуры проекта, программирование, отладку и тестирование. Первый этап заканчивается выпуском первой версии и началом эксплуатации программы у заказчика (или у массы пользователей, если программа была разработана по собственной инициативе для распространения или продажи). Затем наступает этап сопровождения, который включает устранение обнаруживаемых ошибок, адаптацию к постоянно изменяющимся требованиям заказчика, ввод дополнительных возможностей, которые не были оговорены в исходном задании. Часто бывает так - за время сопровождения программа претерпевает настолько существенные изменения, что сопровождение ее становится делом гораздо более трудоемким и хлопотным, чем разработка.Если первый этап достаточно хорошо поддерживается разнообразным программистским инструментарием, то второй этап в этом смысле поддержан значительно хуже. Главной целью "многозвенного программирования" как раз и является поддержка этапа сопровождения. В чем основная идея этого подхода? Рассмотрим простую схему:
разработчик <---> заказчик
В этой схеме заказчик использует только те функциональные возможности программы, которые предоставлены разработчиком. Для изменения этих возможностей заказчик выставляет требования разработчику, разработчик изменяет программу и возвращает заказчику. Таким образом, при интенсивном изменении требований к программе, у разработчика всегда большая загрузка, а у заказчика постоянно тормозится работа. Рассмотрим другую схему:
разработчик <---> технолог <---> пользователь
В этой схеме заказчик образно разделяется на две составляющие - технолог и пользователь. Под технологом здесь понимается человек (или группа), который является посредником между разработчиком и пользователем. Технолог профессионально владеет той предметной областью, для которой разработана программа, но не является программистом - это может быть энергетик, астроном, режиссер. Причем, такое разделение заказчика может быть чисто условным - один и тот же человек может выполнять функции, как технолога, так и конечного пользователя. Технолог - это ключевое звено в цепочке. Технолог знает предметную область значительно лучше разработчика и, весьма часто, хотел бы изменить функционирование программы так, как не было предусмотрено программистом. Частые обращения к разработчику могут быть весьма затруднительными - как во времени, так и в пространстве.
Для улучшения этой ситуации можно сделать следующее - передать часть работы программиста технологу. Поскольку технолог по определению не является программистом, нужна дополнительная связующая часть. Такой связующей частью может быть проблемно-ориентированный язык, который разработчик включает в свой проект и которым технолог может воспользоваться для изменения функциональности программы (в разумных пределах). Естественно, что этот язык должен оперировать терминами той предметной области, в которой работает технолог. То есть, между формулировкой задачи и языком ее решения нужен минимальный семантический разрыв. Универсальные языки программирования на эту роль явно не подойдут. Внешней синтаксической формой проблемно-ориентированного языка может быть текст, граф, схема, короче то, на чем технолог наиболее адекватно формулирует свои конкретные задачи. Таким образом, интенсивность взаимодействия между разработчиком и технологом может быть уменьшена, так как значительную часть изменений технолог может делать самостоятельно.
Эта идея используется многими разработчиками, но в литературе я не встречал ее обсуждения как инструмента для сопровождения. В этом смысле вместо термина "многозвенное программирование" обычно используется термин "проблемно-ориентированный язык".
В многозвенной структуре, которую я нарисовал выше, содержится только 2 программирующих звена, но в реальности этих звеньев может быть больше. Если предметная область достаточно разнородна, то "технолог" может быть целой цепочкой технологов - конкретный пример я приведу в самом конце статьи.
Конечно, здесь есть и другая сторона медали - маркетинговые соображения. Если заказчик получит развиваемый инструмент, то разработчик может остаться в проигрыше. И чем лучше инструмент, тем менее вероятно, что заказчик будет оплачивать сопровождение программы. Здесь уже решать разработчику - или заниматься только сопровождением старых программ или высвобождать время для новых разработок.
Введение в анимацию
Анимация заключается в последовательной смене картинок. При этом главная проблема - устранение мерцания изображения. В программе Canvas2 мерцание "резиновой" линии в целом незаметно, так как эта линия постоянно изменяет своё положение, а вот мерцание подложки, на которой нарисованы уже "впечатанные" в неё линии, было бы заметно, поэтому пришлось принимать специальные меры по её устранению.Чтобы не было мерцания при обновлении изображения, необходимо выполнение двух условий:
Максимальную скорость вывода при использовании средств GDI даёт вывод изображения на поверхность растра (bitmap) с последующим перенесением на экран. Этим обеспечивается то, что все элементы рисунка выводятся на экран одновременно, а не по очереди, что позволяет избежать промежуточных изображений. Поэтому программа Canvas2 хранит растр, на котором отображаются уже завершённые кривые, и при обработке события OnPaint рисует растр, а сверху - редактируемую в данный момент кривую с дополнительными элементами, облегчающими редактирование. Тем не менее, это не устраняет мерцание полностью, если для обновления окна использовать метод TWinControl.Refresh или TWinControl.Invalidate. Это связано с особенностями рисования окон в Windows и с тем, как VCL использует эти особенности.
Для перерисовки сначала с помощью функций InvalidateRect или InvalidateRgn отмечается область окна, нуждающаяся в обновлении. Можно последовательно отметить несколько областей - система будет добавлять новую область к уже существующей. Затем с помощью функции UpdateWindow в очередь сообщений помещается WM_Paint. Рисование окна происходит при обработке этого сообщения. Для начала рисования вызывается функция BeginPaint. Эта функция анализирует область, нуждающуюся в обновлении, и, если при вызове функций InvalidateRect/Rgn был установлен флаг обновления фона, посылает окну сообщение WM_EraseBknd. В ответ на это сообщение окно закрашивает свою клиентскую часть заданной кистью. В частности, для форм Delphi это будет сплошная кисть с цветом, определяемым свойством Color формы. Поэтому сначала будет стёрто старое изображение, и лишь затем будет нарисовано новое. Это приводит к появлению мерцания.
Существует три способа избавиться от мерцания:
к адресному пространству чужого процесса.
Компонент предназначен для доступа к адресному пространству чужого процесса. Позволяет читать память процесса, записывать данные любой длины в память процесса и замораживать данные любой длины в памяти процесса. Можно работать одновременно с любым количеством запущенных на компьютере процессов.| Принцип работы компонента |
Чтобы получить доступ к процессу, компонент использует динамическую библиотеку. Устанавливается ловушка типа WH_CALLWNDPROC, которая реагирует на сообщения, посылаемые функцией SendMessage. После установки ловушки, компонент посылает сообщение WM_NULL целевому окну и, библиотека отображается на адресное пространство процесса (если не была отображена раньше), которому принадлежит целевое окно.
Эта технология подробно описывается в книге Джеффри Рихтера (как и ряд других технологий для тех же целей), поэтому особо подробно останавливаться не буду. Для того чтобы активировать компонент, предназначен метод:
function Activate: Boolean; virtual; который устанавливает ловушку, создает информационный файл, отображаемый в память, в общем, делает некоторую подготовительную работу. Для того чтобы деактивировать компонент, предназначен метод:
function Deactivate: Boolean; virtual; который убирает ловушку и закрывает все отображаемые в память файлы. Впрочем, активировать и деактивировать компонент, а также проследить его состояние можно, используя свойство:
property Active: Boolean; Явно вызывать метод Activate не обязательно, так как при вызове методов компонента проверяется статус компонента и, если надо, производится его активация. Метод:
function UpdateWndData: Boolean; virtual; получает информацию обо всех доступных в системе процессах и их окнах. После вызова этой функции становятся доступны следующие свойства:
property ProcessId_: THandles; содержит дескрипторы процессов;
property ProcessSize: TIntArray; содержит размеры процессов;
property WndHandle: THandles; содержит дескрипторы окон процессов;
property WndClassName: TStrings; содержит имена классов окон;
property WndText: TStrings; содержит заголовки окон;
property ModuleFileName: TStrings; содержит имена исполняемых файлов окон; Вышеперечисленные свойства представляет собой массивы данных, где любой элемент массива соответствует элементу любого другого массива с тем же индексом. Таким образом, все вышеперечисленные свойства имеют одинаковую длину, а элементы свойств с одинаковыми индексами относятся к одному и тому же процессу. Свойство компонента:
property Selected: Integer; обозначает индекс выбранного элемента вышеперечисленных массивов. Это свойство можно установить исходя из, например, заголовка окна:
… var Index: Integer; begin Index := 10; with MemoryInspector do if WndText[Index] = ‘Microsoft Internet Explorer’ then Selected := Index; end; … или это свойство можно установить исходя из имени класса окна:
… var Index: Integer; begin Index := 10; with MemoryInspector do if WndClassName[Index] = ‘IEFrame’ then Selected := Index; end; … Зная дескриптор окна, можно получить индекс, соответствующий свойству Selected:
function GetWindowIndex(Window: THandle): Integer; virtual;
| Чтение памяти процесса |
Чтение памяти процесса осуществляется функцией:
function PeekData: Boolean; virtual; Перед тем, как считывать данные процесса, необходимо установить некоторые свойства компонента. Первым делом, необходимо обновить информацию обо всех доступных в системе процессах и их окнах. После этого выбрать какое-нибудь окно целевого процесса и установить свойство Selected. В результате вызова функции PeekData данные записываются в поток памяти. Этот поток вы должны создать сами и установить ссылку на объект потока в свойстве компонента:
property StreamRef: TMemoryStream; После того, как заданы свойства Selected и StreamRef, можно вызывать функцию PeekData. Работа функции PeekData зависит от свойства:
property UpdateMemory: Boolean; Это свойство обозначает, будет ли перед считыванием памяти обновляться информация о регионах памяти и их блоках в выбранном процессе. Если это свойство истинно, то размер считываемой памяти будет, вероятно, изменяться. Когда память считывается первый раз, это свойство значение не имеет, библиотека обновляет информацию о памяти процесса в любом случае. В последующих вызовах функции PeekData можно либо заново обновить информацию (UpdateMemory = True), либо использовать ту информацию о памяти, которая была получена в первый раз (UpdateMemory = False). Работа функции PeekData также зависит от свойства компонента, которое определяет правила чтения памяти или записи в память:
property ReadOptions: TReadOptions; где
TProtect = (apPageReadOnly, apPageReadWrite, apPageWriteCopy, apPageExecute, apPageExecuteRead, apPageExecuteReadWrite, apPageExecuteWriteCopy, apPageNoAccess); TProtectSet = set of TProtect; определяет набор атрибутов защиты страниц памяти;
TSpecial = (spPageGuard, spPageNoCache); TSpecialProtect = set of TSpecial; определяет набор специальных атрибутов защиты страниц памяти;
TPageType = (ptMemImage, ptMemMapped, ptMemPrivate); TPageTypeSet = set of TPageType; определяет тип физической памяти страниц
TReadOptions = record ChangeProtect: Boolean; ProhibitedProtect, PermittedProtect: TProtectSet; ProhibitedSpecialProtect: TSpecialProtect; ProhibitedPageType: TPageTypeSet; end; Описание атрибутов защиты страниц памяти:
Описание специальные атрибутов защиты страниц памяти:
Тип страниц регионов памяти:
Структура TReadOptions:
Значение свойства ReadOptions по умолчанию настроено оптимальным образом.
| Блоки памяти |
Как уже было сказано, вся память редактируемого процесса разбита на регионы и блоки. Когда библиотека читает память, она берет ее по кусочкам из каждого блока, а потом склеивает воедино и передает в компонент. Таким образом, каждый байт полученной памяти принадлежит какому-то блоку в том процессе, где он был взят. Так вот, если у вас есть, например, память какого-то процесса размером, скажем, в 10 мегабайт, и вы обнаружили в этой памяти нужное вам число, адрес которого 100 байт, то вы, естественно, хотите изменить его. Можно поступить несколькими способами:
Для получения блока памяти используется функция:
function TMemoryInspector.GetMemoryRegion(LocalAddress: Longword): Boolean; Ее параметр LocalAddress это и есть адрес числа в нашем примере, по которому мы хотим получить соответствующий блок в редактируемом процессе. В результате вызова этой функции изменяются некоторые свойства компонента:
property Beginning: Integer; Используется библиотекой и обозначает сумму размеров разрешенных блоков памяти, предшествующих полученному блоку. Значение этого свойства необходимо для некоторых методов записи.
property MemoryRegion: TRegion; TRegion = record AllocationBase, BaseAddress: Pointer; AllocationProtect, Protect: TProtect; SpecialProtect: TSpecialProtect; PageState: TPageState; RegionSize: Longword; PageType: TPageType; end; Это и есть нужный нам блок памяти. Отдельные значения полей записи TRegion вряд ли вам понадобятся, так как свойство MemoryRegion нужно только для методов записи. Тем не менее, я кратко опишу эти поля:
Все подготовительные работы для записи числа по адресу 100 завершены. Теперь можно приступать к записи:
function Write(MemoryRegion: TRegion; Start, Beginning: Longword; Buffer: TShareBuffer; Length: Longword = 0): Boolean; overload; virtual; function WriteByte(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Byte): Boolean; overload; virtual; function WriteWord(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Word): Boolean; overload; virtual; function WriteLongword(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Longword): Boolean; overload; virtual; function WriteInt64(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Int64): Boolean; overload; virtual; function WriteSingle(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Single): Boolean; overload; virtual; function WriteDouble(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Double): Boolean; overload; virtual; function WriteExtended(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Extended): Boolean; overload; virtual; function WriteString(MemoryRegion: TRegion; Start, Beginning: Longword; Value: ShortString): Boolean; overload; virtual; function WriteBuffer(MemoryRegion: TRegion; Start, Beginning: Longword; Value: Pointer; Length: Longword): Boolean; overload; virtual; function WriteBuffer(MemoryRegion: TRegion; Start, Beginning: Longword; Value: TByteArray): Boolean; overload; virtual; function WriteBuffer(MemoryRegion: TRegion; Start, Beginning: Longword; Value: string): Boolean; overload; virtual; Осталось выбрать наиболее подходящую функцию для записи. Несколько слов об общих параметрах функций. Параметры MemoryRegion и Beginning это то, о чем мы только что говорили. Параметр Start это адрес начала записи в масштабе блока памяти: Start = LocalAddress – Beginning. Базовый метод записи Write требует параметр Buffer, который имеет тип:
TShareBuffer = record case Byte of 0: (ByteArray: TSmallByteArray); 1: (CharArray: TSmallCharArray); 2: (ValueRecord: TValueRecord); 3: (Float80: Extended); end; где
TSmallByteArray = array[Byte] of Byte; TSmallCharArray = array[Byte] of Char; TValueRecord = record case Byte of 0: (ByteArray: array[0..7] of Byte); 1: (Signed8: Shortint); 2: (Unsigned8: Byte); 3: (Signed16: Smallint); 4: (Unsigned16: Word); 5: (Signed32: Longint); 6: (Unsigned32: Longword); 7: (Signed64: Int64); 8: (Float32: Single); 9: (Float64: Double); end; Как видно, параметром Buffer может быть представлено практически любое значение, имеющее наиболее распространенный тип и небольшой размер. Если требуется записать значение, длина которого превышает размер структуры TShareBuffer, следует использовать методы типа WriteBuffer. Такие методы могут записывать значения неограниченной длины. Параметры Value методов WriteBuffer имеют тип:
В итоге я приведу полный код примера, в котором требуется записать в память процесса число по локальному адресу 100: …
const Value: Int64 = 1000; var LocalAddress, Start: Integer; MemoryInspector: TMemoryInspector; Stream: TMemoryStream; begin MemoryInspector := TMemoryInspector.Create(Self); MemoryInspector.Parent := Self; with MemoryInspector do begin // Получаем информацию обо всех процессах и их окнах: UpdateWndData; // Выбираем самый первый процесс: Selected := 0; // Устанавливаем адрес: LocalAddress := 100; // Получаем блок памяти: GetMemoryRegion(LocalAddress); // Устанавливаем начало записи: Start := LocalAddress - Beginning; // Запись: WriteInt64(MemoryRegion, Start, Beginning, Value); // Память процесса можно загрузить в поток и сохранить в файл: Stream := TMemoryStream.Create; try StreamRef := Stream; PeekData; Stream.SaveToFile('stream.dat'); finally Stream.Free; end; end; …
| Простые методы записи |
Второй метод записи был только что подробно рассмотрен. Теперь пришла очередь описать первый метод, наиболее простой. Он работает немного медленнее предыдущего, но все же обладает некоторым преимуществом. Представьте себе ситуацию, вы собираетесь записать число размером, скажем 10 байт. Тот блок, в котором будет производиться запись, имеет размер, например 4096 байт, запись начинается с 4092 байта. Получается, что в регион может быть записано только 4 байта, а нужно записать 10 байт. Функции второго типа, которые были рассмотрены в предыдущей главе, в такой ситуации запишут только 4 байта из 10. Функции первого типа ведут себя иначе и в рассматриваемой ситуации сначала найдут следующий блок памяти, запишут в него неуместившиеся 6 байт, после чего запишут первые 4 байта в исходный блок памяти. Ниже приведен список функций первого типа:
Список этих функций соответствует уже рассмотренному списку функций, есть лишь некоторая разница лишь в параметрах. Параметр LocalAddress обозначает адрес начала записи в масштабе полученной памяти редактируемого процесса, т.е. в масштабе объекта потока памяти, на который ссылается свойство StreamRef. Я приведу код примера, который обсуждался в предыдущей главе, но применительно к рассматриваемым методам записи:
… const Value: Int64 = 1000; var LocalAddress: Integer; MemoryInspector: TMemoryInspector; Stream: TMemoryStream; begin MemoryInspector := TMemoryInspector.Create(Self); MemoryInspector.Parent := Self; with MemoryInspector do begin // Получаем информацию обо всех процессах и их окнах: UpdateWndData; // Выбираем самый первый процесс: Selected := 0; // Устанавливаем адрес: LocalAddress := 100; // Запись: WriteInt64(LocalAddress, Value); // Память процесса можно загрузить в поток и сохранить в файл: Stream := TMemoryStream.Create; try StreamRef := Stream; PeekData; Stream.SaveToFile('stream.dat'); finally Stream.Free; end; end; …
| Заморозка значений |
Технология заморозки значений практически ничем не отличается от технологии записи на уровне блока памяти:
Как видно, список этих функций отличается от списка функций записи только одним дополнительным параметром. Параметр Elapse обозначает частоту обновления в миллисекундах. После вызова любой из этих функций, изменяется свойство компонента, которое обозначает состояние заморозки:
property Frozen: Boolean; В любой момент времени может быть заморожено только одно значение одного процесса. Для разморозки предназначена функция:
function Unfreeze: Boolean; virtual; Ниже приведен код пример, который рассматривался в предыдущих главах, где вместо записи мы замораживаем значение:
… const Value: Int64 = 1000; var LocalAddress, Start: Integer; MemoryInspector: TMemoryInspector; Stream: TMemoryStream; begin MemoryInspector := TMemoryInspector.Create(Self); MemoryInspector.Parent := Self; with MemoryInspector do begin // Получаем информацию обо всех процессах и их окнах: UpdateWndData; // Выбираем самый первый процесс: Selected := 0; // Устанавливаем адрес: LocalAddress := 100; // Получаем блок памяти: GetMemoryRegion(LocalAddress); // Устанавливаем начало заморозки: Start := LocalAddress - Beginning; // Заморозка с интервалом обновления 500 мс: FreezeInt64(500, MemoryRegion, Start, Beginning, Value); … // Разморозка: Unfreeze; // Память процесса можно загрузить в поток и сохранить в файл: Stream := TMemoryStream.Create; try StreamRef := Stream; PeekData; Stream.SaveToFile('stream.dat'); finally Stream.Free; end; end; …
| Установка компонента |
Компонент состоит из нескольких частей. Первая часть это, собственно, сам компонент и набор необходимых вторичных компонентов. Вторая часть это используемая компонентом библиотека. Несколько слов о вторичных компонентах и файлах:
Порядок установки компонента:
Необходимо, чтобы еще одна копия файла Mi.dll находилась в одной директории с исходными файлами программы, использующей компонент.
| Ресурсы |
Скачать: (16 K)
Архив содержит:
Дополнительную информацию, а также пример по использованию этого компонента вы сможете найти на сайте .
Выравнивание текста по ширине с автоматическим переносом русских слов.
| Раздел Подземелье Магов | Антон Григорьев , дата публикации |
Программа ByWidth, написанная специально для , предназначена для демонстрации того, как средствами Delphi можно организовать просмотр текста с выравниванием по ширине и автоматическим переносом русских слов.
Краткое описание :
Для переноса слов программа не использует словарь, а анализирует каждое слово с точки зрения правил русского языка. Правила эти достаточно сложны, поэтому иногда программа выбирает не самое изящное, хотя и не неправильное решение. Прежде всего это касается тех слов, в которых три или более согласных идут подряд. Программа может вставить перенос между любыми из них, хотя есть дополнительные правила, которые при этом игнорируются.
Например, то, что приставка должна оставаться целой. Слишком муторно было бы заставлять компьютер учить все приставки. Да ещё и объяснять, что, например, в слове "президент" "пре" - это не приставка, а в слове "предлог" приставка не "пре", а "пред". Тогда уж лучше и в самом деле словарь. Впрочем, демонстрационная программа и есть демонстрационная программа, кто захочет, посмотрит, поймёт основные принципы и сделает лучше.
Из улучшений, которые так и напрашиваются, стоит назвать красную строку и разбивку текста на несколько абзацев. Но это делается настолько элементарно, что мне даже не хочется на этом останавливаться.
Можно ввести перенос английских слов (сейчас программа их переносить не умеет, потому что я не слишком хорошо знаком с английскими правилами переноса), можно ввести запрет на перенос слов из прописных букв - возможностей для творчества хватает, было бы желание.
Я же реализовал простейший вариант - при запуске программа ищет файл ByWidth.txt, мешает все слова в одну кучу, удаляет все лишние пробелы и разбивает на строки нужной длины, перенося при необходимости слова. Предполагается, что в исходном тексте нет переносов, в том числе и тех слов, которые пишутся через дефис. Таким образом, исходный текст может быть написан хоть в одну строку, хоть по одному слову на строку - разницы не будет. И можно вставлять пустые строки - они всё равно игнорируются.
Примечание:
Защита от дурака в программе отсутствует, поэтому если файл ByWidth.txt не будет содержать никакого текста, никаких вежливых предупреждений не будет. Тот, кто захочет приспособить этот пример для чего-то полезного, без проблем добавит эту защиту, а загромождать демонстрацинную программу вряд ли стоит.
Вызов процедуры клиента
Асинхронный вызов процедуры (функции) клиента - один из древнейших способов взаимодействия сервера с клиентом. Это и обработчики прерываний (аппаратных и программных), это и callback-функции, используемые в Win32API, и т.д. Суть в следующем: клиент сообщает серверу адрес своей процедуры (и, возможно, некоторые параметры для ее вызова), а затем сервер в нужный момент ее вызывает.Главный недостаток - процедура выполняется в контексте вызывающего потока (сервера), и программист должен сам принять необходимые меры для синхронизации с потоком клиента, если имеются обращения к разделяемым данным. Кроме того, процедура должна выполниться достаточно быстро, чтобы не задерживать работу сервера (всяческие ожидания и SendMessage, явные и неявные, тут недопустимы). Вследствие некоторой противоречивости данных требований можно рекомендовать следующий метод работы: выполнить в асинхронной процедуре некие оперативные вычисления, а затем известить поток клиента способом, не требующим задержки (например - PostMessage), и быстренько отдать управление серверу.
Асинхронный вызов метода класса (procedure of object) является разновидностью данного метода.
Взгляд в будущее
Пока эта статья создавалась, меня стали обуревать новые идеи. Потихоньку начал возникать код нового Инспектора. А идеи таковы:Waveform Audio Win32 API. Часть I
| Раздел | лилов дата публикации 29 апреля 2000. |
Введение
Одной из наиболее важных частей Multimedia-API Windows 95/98/NT по праву может считаться Waveform Audio. Предоставляя наиболее широкие возможности по работе с оцифрованным звуком, эта группа функций таит в себе немало "подводных камней". сил приложил к исследованию вопроса оптимального применения этих функций и хотел бы поделиться своими "открытиями" с читателями. Приводимые здесь примеры могут использоваться совершенно свободно, за исключением особо оговоренных случаев. Первая часть открывает небольшую серию статей, посвященных обработке звука в режиме реального времени (это когда время реакции системы на событие строго ограничено и не превышает заранее заданной величины - т.н. "жесткие" системы реального времени). Если Вы рассчитываете увидеть здесь разбор каких-то особенно сложных алгоритмов кодирования или сжатия звука - разочарую Вас. Далее применения быстрого преобразования Фурье пока ничего шибко математического не планируется. Обратите внимание, что вся информация почерпнута из Microsoft Multimedia Programmer's Reference, поэтому всячески рекомендую обращаться туда, тем более, что эти файлы включены в поставку Delphi 3, 4, 5.
В первой части рассматривается использование функций Waveform Audio Win32 API. мнению, функций и рассматривает пример реализации программы, записывающей звук в WAV-файл в течение "неограниченного" времени. Приведенный в статье пример реализован на Delphi 4.
Часть 1
Оцифрованный звук может быть представлен самыми различными способами. В числе наиболее широко применяемого способа цифрового представления звука можно отметить формат PCM - pulse code modulation - импульсно-кодовая модуляция. В контексте нашей тематики под этим термином подразумевается такой способ кодирования данных, при котором каждая выборка (отсчет), произведенная аналого-цифровым преобразователем (здесь - в смысле звуковой карты), представляется в памяти в виде числа, пропорционального по своему значению мгновенной величине сигнала в момент выборки. Скорость выборок или, другими словами, частота выполнения отсчетов (частота дискретизации), прямо связана с максимальной частотой поступающего аналогового сигнала. Если сигнал имеет гармоническую природу и ограничен в некотором диапазоне частот, т.е. может быть представлен в виде конечного числа членов ряда Фурье, то для его корректной оцифровки, согласно теореме отсчетов, достаточно иметь частоту дискретизации вдвое превосходящей частоту максимальной гармоники сигнала.
Таким образом, если мы хотим без потери качества производить цифровую запись скажем, телефонного разговора, частота сигнала которого находится в диапазоне 300..3400 Гц, нам вполне достаточно установить частоту дискретизации 8000 отсчетов/сек. Величина 8000 выбрана из соображений совместимости с различными звуковыми картами и драйверами, поскольку для некоторых из них это является наименьшим возможным значением частоты дискретизации сигнала. Если же Вы хотите записывать радиопередачи в диапазоне FM (88 - 108 MHz), то необходимо выбрать частоту дискретизации 12500*2=25000 отсчетов/сек, т.к. звуковой диапазон FM-станции 12.5 килогерц.
Как Вы уже наверное догадались, запись с компакт-диска для сохранения качества нужно производить с частотой дискретизации 44100 выборок/секунду. Замечу, что это вовсе не гарантирует качество звучание записи "как на CD-ROM". Звуковая карта вносит некоторые искажения в любом случае. Как правило, это напрямую связано со стоимостью карты. Более дорогие обычно обеспечивают лучшее качество.
Теперь более подробно рассмотрим некоторые из функций, позволяющие работать со звуком.
Прежде всего, рассмотрим функцию waveInGetNumDevs:
function waveInGetNumDevs: UINT; stdcall; - функция возвращает количество устройств ввода, поддерживающих оцифровку звукового сигнала. Если функция вернула 0, то таких устройств в системе нет.
Функция waveInGetDevCaps позволяет получить характеристики указанных устройств.
function waveInGetDevCaps(
hwi: HWAVEIN;
lpCaps: PWaveInCaps;
uSize: UINT ): MMRESULT; stdcall;
Здесь
hwi - идентификатор открытого функцией waveInOpen (см. ниже) устройства или порядковый номер неоткрытого устройства в диапазоне от 0 до значения, возвращаемого функцией waveInGetNumDevs, уменьшенного на 1;
lpCaps - адрес структуры (записи) TWAVEINCAPS; uSize - размер в байтах структуры TWAVEINCAPS.
type TWaveInCaps = record wMid: Word;
wPid: Word;
vDriverVersion: MMVERSION;
szPname: array[0..MAXPNAMELEN-1] of AnsiChar;
dwFormats: DWORD;
wChannels: Word;
wReserved1: Word; end;
Структура TWAVEINCAPS описывает параметры заданного устройства. Т.е. после вызова функции waveInGetDevCaps поля структуры содержат следующие значения:
wMid: Word - идентификатор производителя;
wPid: Word - идентификатор продукции производителя;
vDriverVersion: MMVERSION - версия драйвера;
szPname: array[0..MAXPNAMELEN-1] of AnsiChar - наименование продукта (строка заканчивается символом с кодом 0);
dwFormats: DWORD - стандартные форматы данных, поддерживаемые устройством:
| WAVE_FORMAT_1M08 |
11.025 kHz, mono, 8-bit |
| WAVE_FORMAT_1M16 |
11.025 kHz, mono, 16-bit |
| WAVE_FORMAT_1S08 |
11.025 kHz, stereo, 8-bit |
| WAVE_FORMAT_1S16 |
11.025 kHz, stereo, 16-bit |
| WAVE_FORMAT_2M08 |
22.05 kHz, mono, 8-bit |
| WAVE_FORMAT_2M16 |
22.05 kHz, mono, 16-bit |
| WAVE_FORMAT_2S08 |
22.05 kHz, stereo, 8-bit |
| WAVE_FORMAT_2S16 |
22.05 kHz, stereo, 16-bit |
| WAVE_FORMAT_4M08 |
44.1 kHz, mono, 8-bit |
| WAVE_FORMAT_4M16 |
44.1 kHz, mono, 16-bit |
| WAVE_FORMAT_4S08 |
44.1 kHz, stereo, 8-bit |
| WAVE_FORMAT_4S16 |
44.1 kHz, stereo, 16-bit |
Обратите внимание на то, что подавляющее большинство (если не все) звуковые карты поддерживают промежуточные режимы записи-воспроизведения. Т.е. вполне возможно на карте с максимальной частотой дискретизации 44100 выборок/сек производить запись со скоростью 16000 выборок/сек, хотя это и не сообщается по запросу waveInGetDevCaps. wChannels: Word - количество входных каналов (1-моно, 2-стерео)
wReserved1: Word - зарезервировано
Функция waveInGetErrorText возвращает текстовое описание возникших в ходе выполнения ошибок.
function waveInGetErrorText(
mmrError: MMRESULT;
lpText: PChar;
uSize: UINT
): MMRESULT; stdcall;
mmrError - код ошибки;
lpText - адрес с которого будет размещена нуль-терминированная строка-описание;
uSize - размер участка памяти, на который ссылается lpText;
Ниже приведен пример процедуры, выводящей сведения об устройствах аудиоввода.
| uses Windows, MMSystem; type TModeDescr=record mode: DWORD; // код режима работы descr: string[32]; // словесное описание end; const // массив содержит сопоставления режима работы и словесного описания modes: array [1..12] of TModeDescr=((mode: WAVE_FORMAT_1M08; descr:'11.025 kHz, mono, 8-bit'), (mode: WAVE_FORMAT_1M16; descr:'11.025 kHz, mono, 16-bit'), (mode: WAVE_FORMAT_1S08; descr:'11.025 kHz, stereo, 8-bit'), (mode: WAVE_FORMAT_1S16; descr:'11.025 kHz, stereo, 16-bit'), (mode: WAVE_FORMAT_2M08; descr:'22.05 kHz, mono, 8-bit'), (mode: WAVE_FORMAT_2M16; descr:'22.05 kHz, mono, 16-bit'), (mode: WAVE_FORMAT_2S08; descr:'22.05 kHz, stereo, 8-bit'), (mode: WAVE_FORMAT_2S16; descr:'22.05 kHz, stereo, 16-bit'), (mode: WAVE_FORMAT_4M08; descr:'44.1 kHz, mono, 8-bit'), (mode: WAVE_FORMAT_4M16; descr:'44.1 kHz, mono, 16-bit'), (mode: WAVE_FORMAT_4S08; descr:'44.1 kHz, stereo, 8-bit'), (mode: WAVE_FORMAT_4S16; descr:'44.1 kHz, stereo, 16-bit')); procedure ShowInfo; var WaveNums, i, j: integer; WaveInCaps: TWaveInCaps; // структура в которую помещается информация об устройстве begin WaveNums:=waveInGetNumDevs; if WaveNums>0 then // если в системе есть устройства аудиоввода,то begin for i:=0 to WaveNums-1 do // получаем характеристики всех имеющихся устройств begin waveInGetDevCaps(i,@WaveInCaps,sizeof(TWaveInCaps)); // добавляем наименование устройства MainForm.Memo.Lines.Add(PChar(@WaveInCaps.szPname)); for j:=1 to High(modes) do begin // выводим поддерживаемые устройством режимы работы if (modes[j].mode and WaveInCaps.dwFormats)=modes[j].mode then Memo.Lines.Add(modes[j].descr); end; end; end; end; |
Рис 1. Сведения, выводимые процедурой ShowInfo.
Теперь Вы можете определить количество устройств аудиоввода Waveform audio и поддерживаемые ими режимы. Далее рассмотрим еще несколько функций, непосредственно обеспечивающих работу с звуковыми устройствами. Функция waveInOpen открывает имеющееся устройство ввода Waveform audio для оцифровки сигнала.
function waveInOpen( lphWaveIn: PHWAVEIN;
uDeviceID: UINT;
lpFormatEx: PWaveFormatEx;
dwCallback,
dwInstance,
dwFlags: DWORD
): MMRESULT; stdcall;
Здесь
lphWaveIn - указатель на идентификатор открытого Waveform audio устройства. Идентификатор используется после того, как устройство открыто, в других функциях Waveform audio;
uDeviceID - номер открываемого устройства (см. waveInGetNumDevs). Это может быть также идентификатор уже открытого ранее устройства. Вы можете использовать значение WAVE_MAPPER для того, чтобы функция автоматически выбрала совместимое с требуемым форматом данных устройство;
lpFormatEx - указатель на структуру типа TWaveFormatEx
type TWaveFormatEx = packed record wFormatTag: Word; { format type }
nChannels: Word; { number of channels (i.e. mono, stereo, etc.) }
nSamplesPerSec: DWORD; { sample rate }
nAvgBytesPerSec: DWORD; { for buffer estimation }
nBlockAlign: Word; { block size of data }
wBitsPerSample: Word; { number of bits per sample of mono data }
cbSize: Word; { the count in bytes of the size of }
end;
В этой структуре значения полей следующее:
wFormatTag - формат Waveform audio. Мы будем использовать значение WAVE_FORMAT_PCM (это означает импульсно-кодовая модуляция) другие возможные значения смотрите в заголовочном файле MMREG.H;
nChannels - количество каналов. Обычно 1 (моно) или 2(стерео);
nSamplesPerSec - частота дискретизации. Для формата PCM - в классическом смысле, т.е. количество выборок в секунду. Согласно теореме отсчетов должна вдвое превышать частоту оцифровываемого сигнала. Обычно находится в диапазоне от 8000 до 44100 выборок в секунду;
nAvgBytesPerSec - средняя скорость передачи данных. Для PCM равна nSamplesPerSec*nBlockAlign;
nBlockAlign - для PCM равен (nChannels*wBitsPerSample)/8;
wBitsPerSample - количество бит в одной выборке. Для PCM равно 8 или 16;
cbSize - равно 0. Подробности в Microsoft Multimedia Programmer's Reference;
dwCallback - адрес callback-функции, идентификатор окна или потока, вызываемого при наступлении события;
dwInstance - пользовательский параметр в callback-механизме. Сам по себе не используется
dwFlags - флаги для открываемого устройства:
| CALLBACK_EVENT | dwCallback-параметр - код сообщения (an event handle); | |
| CALLBACK_FUNCTION | dwCallback-параметр - адрес процедуры-обработчика; | |
| CALLBACK_NULL | dwCallback-параметр не используется; | |
| CALLBACK_THREAD | dwCallback-параметр - идентификатор потока команд; | |
| CALLBACK_WINDOW | dwCallback-параметр - идентификатор окна; | |
| WAVE_FORMAT_DIRECT | если указан этот флаг, ACM-драйвер не выполняет преобразование данных; | |
| WAVE_FORMAT_QUERY | функция запрашивает устройство для определения, поддерживает ли оно указанный формат, но не открывает его; |
В случае использование Callback процедуры она имеет следующий вид:
procedure waveInProc(hwi: HWAVEIN; uMsg,dwInstance, dwParam1,dwParam2: DWORD);stdcall; begin // что-то делаем end; Параметры процедуры имеют следующее значение:
hwi - идентификатор связанного с функцией открытого устройства;
uMsg - Waveform audio сообщение. Может принимать значения:
| WIM_CLOSE | посылается, когда устройство закрывается функцией waveInClose; |
| WIM_DATA | устройство завершило передачу данных в блок памяти, установленный процедурой waveInAddBuffer; |
| WIM_OPEN | сообщение посылается если устройство открыто функцией waveInOpen; |
dwParam1, dwParam2 - параметры сообщения.
Необходимо заметить, что в Microsoft Multimedia Programmer's Reference написано, что из callback-процедуры нельзя вызывать никаких системных функций кроме:
EnterCriticalSection, LeaveCriticalSection, midiOutLongMsg, midiOutShortMsg, OutputDebugString, PostMessage, PostThreadMessage, SetEvent, timeGetSystemTime, timeGetTime, timeKillEvent, и timeSetEvent , поскольку это вызывает deadlock.
Я столкнулся с весьма серьезным препятствием из-за этого ограничения, и решил все-таки рискнуть. В ходе небольших экспериментов я выяснил, что данное ограничение не распространяется на группу waveInAddBuffer, waveInReset и waveInClose, и возможно, некоторые другие. Не было проблем и с использованием функций Reset, BlockWrite, BlockRead, CloseFile. Говоря более точно, я так и не обнаружил возникновения deadlock, какие бы функции не вызывал изнутри waveInProc. Самое главное - не инициировать бесконечный рекурсивный вызов waveInProc. Для этого необходимо хорошо продумать обработчики поступающих в waveInProc сообщений.
Вообще, рекомендую использовать механизм оконных сообщений вместо callback. Это позволяет избежать ненужных экспериментов и возможной неработоспособности программы в других версиях ОС. Более подробно реализация этого механизма приведена в примере. Функция waveInPrepareHeader выполняет подготовку буфера для операции загрузки данных:
function waveInPrepareHeader( hWaveIn: HWAVEIN;
lpWaveInHdr: PWaveHdr;
uSize: UINT
): MMRESULT; stdcall;
Здесь:
hWaveIn - идентификатор открытого устройства;
lpWaveInHdr - адрес структуры WaveHdr:
type TWaveHdr = record lpData: PChar; { pointer to locked data buffer }
dwBufferLength: DWORD; { length of data buffer }
dwBytesRecorded: DWORD; { used for input only }
dwUser: DWORD; { for client's use }
dwFlags: DWORD; { assorted flags}
dwLoops: DWORD; { loop control counter }
lpNext: PWaveHdr; { reserved for driver }
reserved: DWORD; { reserved for driver }
end;
lpData - адрес буфера для загрузки данных;
dwBufferLength - длина буфера в байтах;
dwBytesRecorded - для режима загрузки данных определяет количество загруженных в буфер байт;
dwUser - пользовательские данные
dwFlags - флаги. Могут иметь следующие значения:
| WHDR_DONE | устанавливается драйвером при завершении загрузки буфера данными; |
| WHDR_PREPARED | устанавливается системой. Показывает готовность буфера к загрузке данных; |
| WHDR_INQUEUE | устанавливается системой когда буфер установлен в очередь; |
lpNext - зарезервировано;
reserved - зарезервировано;
uSize - размер структуры WaveHdr в байтах;
Функция waveInPrepareHeader вызывается только один раз для каждого устанавливаемого в очередь загрузки буфера. Существует функция waveInUnprepareHeader, с такими же параметрами, которая освобождает ресурсы системы по сопровождению выделенного под загрузку блока. waveInUnprepareHeader должна быть вызвана до удаления выделенного под буфер загрузки блока памяти.
Функция waveInAddBuffer ставит в очередь на загрузку данными буфер памяти. Когда буфер заполнен, система уведомляет об этом приложение (см. выше waveInOpen).
function waveInAddBuffer( hWaveIn: HWAVEIN;
lpWaveInHdr: PWaveHdr;
uSize: UINT
): MMRESULT; stdcall;
Здесь:
hWaveIn - идентификатор открытого Waveform audio устройства ввода;
lpWaveInHdr - адрес структуры TWaveHdr;
uSize - размер WaveHdr в байтах;
Функция waveInReset останавливает операцию загрузки данных. Все текущие буферы отмечаются как обработанные и приложение уведомляется о завершении загрузки данных (см. waveInOpen).
function waveInReset( hWaveIn: HWAVEIN ): MMRESULT; stdcall; Здесь:
hWaveIn - идентификатор открытого Waveform audio устройства.
Функция waveInClose закрывает открытое устройство ввода:
function waveInClose(
hWaveIn: HWAVEIN
): MMRESULT; stdcall;
hWaveIn - идентификатор открытого устройства;
MMRESULT может принимать следующие значения:
| MMSYSERR_NOERROR | нет ошибок; | |
| MMSYSERR_ALLOCATED | указанный ресурс уже выделен; | |
| MMSYSERR_BADDEVICEID | указанный идентификатор устройства вне диапазона; | |
| MMSYSERR_NODRIVER | отсутствует драйвер устройства; | |
| MMSYSERR_NOMEM | невозможно выделить или зафиксировать блок памяти; | |
| WAVERR_BADFORMAT | попытка открытия с неподдерживаемым форматом данных; | |
| MMSYSERR_INVALHANDLE | параметром является недопустимый идентификатор; | |
| WAVERR_STILLPLAYING | указанный буфер все еще в очереди; | |
| WAVERR_UNPREPARED | буфер не был подготовлен; |
Александр Галилов
WMI - практика применения в Delphi
| Раздел Подземелье Магов |
| | |
XML сериализация объекта Delphi
| Раздел Подземелье Магов |
В статье рассмотрены возможности прямой загрузки/сохранения XML документов в объекты Delphi/С++Builder и генерации соответствующих DTD. Предлагается оптимизированный компонент для реализации этих возможностей.
Язык XML предоставляет нам чрезвычайно удобный и почти универсальный подход к хранению и передаче информации. Существует множество парсеров для разбора XML документов по модели DOM. На платформе Microsoft Windows - это, в первую очередь, парсеры MSXML от Microsoft.
Парсеры взаимодействуют с вызывающими приложениями посредством интерфейса SAX (Simple API for XML) и/или DOM (Document Object Model). Во всех анализаторах, за исключением продукта фирмы Microsoft, используется SAX, и почти во всех их возможно применение DOM.
Реализация парсера MSXML не плоха, поддерживает проверку семантической корректности документа и с его помощью достаточно удобно загружать небольшие XML документы. Однако для работы с каждым типом документов, реализованном на XML разработчику приходится создавать некий оберточный код для загрузки данных из объекта Microsoft.XMLDOM во внутренние структуры программы или для удобного перемещения по DOM. При изменении формата документа, что часто возможно в части расширения его спецификации, изменения созданного кода могут быть достаточно трудоемкими и требующими тщательной отладки.
Возникает вопрос возможности упростить работу с XML документами, интегрировать их обработку в разрабатываемые программы. Для модели DOM наилучшим является непосредственная загрузка XML документа в объект Delphi/С++Builder. И эта возможность есть. Используя RTTI можно загружать данные непосредственно из тегов XML документа в атрибуты заданного объекта. Соответственно, становится возможным и XML-сериализация published интерфейсов объектов любых классов Delphi.
Рассматриваемый подход дает возможность наиболее удобно интегрировать обработку XML в среду разработки Delphi и C++Builder. Возможность доступа к свойствам объектов определяется через механизмы RTTI. Его возможности в Delphi очень велики, т.к. среда разработки сама хранит ресурсы объектов в текстовом формате.
Очевидно, что за предлагаемыми преимуществами скрываются и ряд ограничений. В первую очередь, это касается атрибутов тегов. У нас нет простых механизмов отличить атрибут от тега при сохранении свойства объекта. Поэтому в предлагаемой реализации мы будем обрабатывать XML документы, не содержащие атрибутов. Это ограничение может стать критическим только если мы хотим поддержать уже существующий тип XML документа. Если же мы разрабатываем формат сами, то вполне можем отказаться от атрибутов. Зато наш парсер будет работать не просто быстро, а очень быстро. ;)
Алгоритм XML-сериализации реализуется в виде рекурсивного обхода published интерфейса объекта. Для начала определим ряд простых функций для формирования XML кода. Они позволят нам добавлять открывающие, закрывающие теги и значения в выходной поток.
Для классовых типов придется использовать рекурсию для загрузки всех свойств соответствующего объекта.
Более того, для ряда классов необходимо использовать особый подход. Сюда относятся, к примеру, строковые списки и коллекции. Ими и ограничимся.
Для текстового списка TStrings будем сохранять в XML его свойство CommaText, а в случае коллекции после обработки всех ее свойств сохраним в XML каждый элемент TCollectionItem отдельно. При этом в качестве контейнерного тега будем использовать имя класса TCollection(PropObject).Items[j].ClassName.
Следует заметить, что при желании можно переписать этот код для генерации также и атрибутов элементов. Для отличия элементов от их атрибутов в интерфейсе сохраняемого объекта можно принять следующее соглашение: элементами являются только классовые типы, все же прочие свойства кодируются как атрибуты соответствующих классов. Соответственно можно модифицировать и парсер. При этом появляется возможность использования XML схем вместо DTD. Тут, однако, возникает проблема описания модели содержания для текста #PCDATA. Для разрешения проблемы придется выделить отдельный класс для хранения подобных данных. Но это тема уже другой статьи.
Продолжение:
Загрузка XML в объект
| Раздел Подземелье Магов |
После того, как мы рассмотрели возможность превода данных объекта в XML следует перейти к следующей задаче. Задача состоит в реализации обратного процесса, а именно - загрузки XML данных в объект.
Загрузка XML данных в объект, или десериализация, представляет собой более сложный процесс, т.к. в ходе его необходимо осуществить корректный разбор текстового XML документа на предмет инициализации содержащимися в нем данными заданного объекта.
Примем ряд упрощений, которые сократят число проверок корректности входящего XML документа к минимуму. Первое, что необходимо делать, тек это проверять соответствие тега верхнего уровня имени класса нашего объекта. Синтаксическая правильность документа будет проверяться в ходе загрузки данных. При необходимости более жесткой проверки загружаемых XML документов можно привлечь, к примеру, парсер MSXML. Последний поможет нам проверить документ на синтаксическую, а также семантическую корректность при наличии соответствующего DTD.
Первое, что следует реализовать, это процедура верхнего уровня, которая получает объект для инициализации, а также потоковый источник данных с текстом XML документа.
Среди свойств объекта отыскивается через FindProperty() оноименное свойство. При неудаче генерируется исключение об ошибочности XML тега. Если для тега найден соответвующее свойство, то передаем дальнейшую обработку процедуре SetPropertyValue(), которая заданное свойство с именем TagName проинициализирует найденным значением TagValue.
Не забываем также передвигать указатель чтения данных TokenPtr по мере выборки данных.
В случае, если тип данные не является классовым типом, то, очевидно, текст Value следует просто загрузить в свойство. Это реализуется вызовом процедуры TypInfo.SetPropValue(). Последняя самостоятельно разберется, как корректно преобразовать тестовое значение в значение свойства в завистимости от его типа.
Если свойство имеет классовый тип, то его значение Value должно содержать XML код, описывающий свойства данного класса. В этом случае воспользуемся рекурсией и передадим обработку вышеприведенной процедуре DeSerializeInternal(). При этом передаем ей в качестве объекта ссылку на найденное свойство PropObject и его имя PropInfo^.Name.
Нам также необходимо озаботиться отдельной обработкой данных для таких классовых типов как списки TStrings и коллекции TCollection. Данные для списков мы загружаем из значения Value как CommaText. Тут все понятно. В сллучае же коллеций данные о элементах коллекции в XML документе содержаться в виде последовательных контейнерных тегов с именем типа элемента коллекци. Т.е., к примеру,
Продолжение
с использованием API вы может
В архиве все исходники примера (73К).Дополнительные сведения о программировании с использованием API вы может посмотреть в справочных файлах, которые идут с CR (PROGRAM FILES\SEAGATSOFTWARE\CRYSTAL REPORTS\DEVELOPER FILES\HELP\), файлы DEVELOPR.HLP и RUNTIME.HLP. Если их у вас нет, то скачайте с .
В будущем я надеюсь развить тему CR более углубленно, но это зависит от интереса читателей и наличия времени :-).
Специально для
я оставил доступными все математические
При составлении этого примера я оставил доступными все математические функции, которые были перечислены выше. Вообще функции типа "random", "frac" или "int" с точки зрения математики не желательны. Но при использовании некоторых из них получаются очень любопытные графики (например, int abs x ^ frac abs x или random * x * sin x). Обратите также внимание, что при изменении максимальных значений осей X или Y перерасчет графика происходит практически мгновенно.Запрос данных от программы Map Info
Для выполнения запроса из Вашей программы-клиента значения MapBasic используйте OLE-методEval.Например: MyVar:= FServer.Eval('здесь команда MapBasic');
Примечание:
В компоненте это реализовано процедурой Eval, но в сущносте вызывается FServer.Eval
При использовании метода Eval программа MapInfo интерпретирует строку как выражение языка MapBasic, определяет значение выражения и возвращает это значение в виде строки. Замечание: Если выражение приводится к логическому значению (тип Logical), MapInfo возвращает односимвольную строку, "Т" или "F" соответственно.
Запуск и остановка пакета
Для того чтобы произвести запуск (активацию) компонентов, установленных в пакете, можно воспользоваться методом StartApplication интерфейса ICOMAdminCatalog. При этом в качестве параметра можно передавать как имя пакета, так и его GUID ComAdminCatalog.StartApplication('COMTest'); Аналогично выполняется и операция остановки компонентов данного пакета. ComAdminCatalog.ShutdownApplication('COMTest');Запуск MapInfo
Запуск уникального экземпляра программы MapInfо осуществляется вызовом функции CreateObject() Visual Basic с присваиванием возвращаемого значения объектной переменной. (Вы можете декларировать объектную переменную как глобальную; в противном случае объект MapInfо освобождается после выхода из локальной процедуры.)Например: FServer := CreateOleObject('MapInfo.Application'); Для подключения к ранее исполнявшемуся экземпляру MapInfo, который не был запущен вызовом функции CreateObject(), используйте функцию GetObject(). // Данная реализация оставлена вам уважаемые читатели для тренировки FServer := GetObject('MapInfo.Application'); Внимание: Если Вы работаете с Runtime-версией MapInfo, а не с полной копией, задавайте "MapInfo. Runtime" вместо "MapInfo. Арplication". Runtime-версия и полная версия могут работать одновременно.
Функции CreateObject() и GetObject() используют механизм управления объектами OLE (OLE Automation) для связи с MapInfo.
Примечание:
В 32-разрядной версии Windows (Windows95 или Windows NT) можно запускать несколько экземпляров MapInfo. Если Вы запустите MapInfo и вслед за этим программу, использующую Интегрированную Картографию и вызывающую CreateObjectf), то будут работать два независимых экземпляра MapInfo. Однако в 16-разрядной версии программа использующая Интегрированную Картографию с запущенным MapInfo работать не сможет.
Завершающие штрихи
Вот, собственно, и все, что мне хотелось объяснить при описании заявленной темы. Остается только добавить, что представленный в статье инспектор доступен в исходных текстах как FreeWare без каких-либо оговорок, кроме единственной - уважать тельные метаклассы, менеджер, реестр и вспомогательные процедуры. Весь код достаточно полно комментирован, так что можно всегда обратиться к нему при возникновении вопросов.Скачать : (88К)
Кроме того, к тексту инспектора приложен простенький пример, картинки из которого использованы в статье: модули UnitMainForm (главная форма примера) и UnitInfo (классы метаданных для объектов, инспектируемых в примере). Пример можно компилировать не устанавливая компонент инспектора в палитру компонентов, так как компонент создается явно во время выполнения.
Россия, Томск.
Специально для
Статьи Королевства Дельфи
с обычными логическими операция над
Наряду с обычными логическими операция над логическими типами Boolean, часто приходятся выполнять операции и над отдельными битами, обычно используемыми, как флаги. Для эффективной работы необходимо понятие логических операций. Паскаль поддерживает следующие логические операции
Каждый бит может иметь только два состояния ЛОЖЬ (FALSE) или ИСТИНА (TRUE)
Состояние бита можно описывать и другими словами, часть которых пришла из математики, часть из электроники, часть из логики.
Для значения ЛОЖЬ, альтернативные варианты такие - [НЕТ, НОЛЬ, ВЫКЛЮЧЕНО, НЕ УСТАНОВЛЕНО, СБРОШЕНО, FALSE, F, 0, -] и другие.
Для значения ИСТИНА, альтернативные варианты такие - [ДА, ЕДИНИЦА, ВКЛЮЧЕНО, УСТАНОВЛЕНО, ВЗВЕДЕНО, TRUE, T, 1, +] и другие.
Рассмотрим эти операции по отдельности AND - логическое И, эта операции выглядит так
| A | B | Y |
| 0 | 0 | 0 |
| 0 | 1 | 0 |
| 1 | 0 | 0 |
| 1 | 1 | 1 |
OR - (включающие) логическое ИЛИ, эта операции выглядит так
| A | B | Y |
| 0 | 0 | 0 |
| 0 | 1 | 1 |
| 1 | 0 | 1 |
| 1 | 1 | 1 |
XOR - (исключающие) логическое ИЛИ, эта операции выглядит так
| A | B | Y |
| 0 | 0 | 0 |
| 0 | 1 | 1 |
| 1 | 0 | 1 |
| 1 | 1 | 0 |
NOT - отрицание или инверсия бита, эта операции применяется только к одному биту, действие простое — текущее значение бита изменяется на противоположное
| A | Y |
| 0 | 1 |
| 1 | 0 |
SHL - логический сдвиг влево, операции применяется только к группе битов, одного из целочисленных типов Паскаля, например к байту, слову и т.д. Сдвиг байта влево на один разряд.
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 0 | 0 | 1 | 1 | 1 | 0 | 1 | 0 |
Сдвиг байта влево на два разряда
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 0 | 1 | 1 | 1 | 0 | 1 | 0 | 0 |
Байт смещается влево на один или более разрядов, позиции справа замещаются нулями, позиции слева теряются.
SHR - логический сдвиг вправо, операции применяется только к группе битов, одного из целочисленных типов Паскаля, например к байту, слову и т.д.
Сдвиг байта вправо на один разряд.
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 0 | 1 | 0 | 0 | 1 | 1 | 1 | 0 |
Сдвиг байта вправо на два разряда.
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 0 | 0 | 1 | 0 | 0 | 1 | 1 | 1 |
Байт смещается вправо на один или более разрядов, позиции слева замещаются нулями, позиции справа теряются.
На этом описание операций заканчивается, и переходим к практическим примерам. Но вначале немного слов о нотации
Применяемая нотация при отображении чисел в литературе
Числа в символьной форме принято отображать, так чтобы младшие разряды были справа, а строки слева, при этом если используется выравнивание, то оно тоже подчиняется этим правилам.
Нумерация разрядов начинается с нуля в соответствии со степень разряда и описывается формулой K*M^N, где K это коэффициент в диапазоне от 0 до M-1, M это основание числа, а N это степень. Число в степени 0 для всех оснований равно 1.
Посмотрим на примере следующей таблицы для четырех основных оснований.
Для числа 100
| Основание | Значение | Формула |
| 2 | 4 | 1*2^2 + 0*2^1 +0*2^0 |
| 8 | 64 | 1*8^2 + 0*8^1 +0*8^0 |
| 10 | 100 | 1*10^2 + 0*10^1 + 0*2^0 |
| 16 | 256 | 1*16^2 + 0*16^1 + 0*2^0 |
Для числа 123
| Основание | Значение | Формула |
| 2 | X | Недопустимая комбинация |
| 8 | 83 | 1*8^2 + 2*8^1 + 3*8^0 |
| 10 | 123 | 1*10^2 + 2*10^1 + 3*10^0 |
| 16 | 291 | 1*16^2 + 2*16^1 + 3*16^0 |
В начале несколько простых примеров по использованию логических операций, а в заключение будет рассмотрено применение этих приемов для работы с каталогами.
Получение позиции бита или его значения
1 shl N
В данном примере единица сдвигается влево на нужное количество разрядов, и в результате получаем двоичное значение, равное 2^N, где установлен один единственный бит, соответствующий разряду числа. Этот прием может использоваться с переменной для расчета позиции во время выполнения или во время компиляции, во втором случае код генерироваться не будет, а компилятор просто рассчитает значение и подставит его в программу, не генерируя дополнительного кода. Это удобно для указания номера бита, не представляя его в виде десятичной или шестнадцатеричной константы. Но чаще бывает удобнее использовать именованные константы, поскольку они более информативны, примеры этого будут приведены в конце статьи.
Установка бита
Для установки отдельного бита или группы битов используется операция ИЛИ, использование иллюстрируется ниже приведенным кодом в виде отдельной функции и результатом выполнения в виде таблицы.
function SetBit(Src: Integer; bit: Integer): Integer; begin Result := Src or (1 shl Bit); end; Здесь происходит следующее:
Сначала мы рассчитываем позицию бита - (1 shl Bit), затем устанавливаем полученный бит и возвращаем результат через предопределенную переменную Result. Пример использования: DummyValue := SetBit(DummyValue, 2);
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До (1) | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| До (2) | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
Как видим, вне зависимости от начального состояние бита, после выполнения операции бит становится равны единице.
Сброс бита
Для сброса отдельного бита или группы битов используется операция И совместно с инверсной маской, использование иллюстрируется ниже приведенным кодом в виде отдельной функции и результатом выполнения в виде таблицы. function ResetBit(Src: Integer; bit: Integer): Integer; begin Result := Src and not (1 shl Bit); end; Здесь происходит следующее:
Сначала мы рассчитываем позицию бита - (1 shl Bit), затем с помощью операции NOT инвертируем полученную маску, устанавливая, не затрагиваемые биты маски в единицу, а затрагиваемый бит в ноль, затем сбрасываем этот бит, а результат возвращаем результат через предопределенную переменную Result.
Пример использования:
DummyValue := ResetBit(DummyValue, 2);
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До (1) | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| До (2) | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
Переключение бита
Для переключения отдельного бита или группы битов используется операция исключающие ИЛИ, использование иллюстрируется ниже приведенным кодом в виде отдельной функции и результатом выполнения в виде таблицы. function InvertBit(Src: Integer; bit: Integer): Integer; begin Result := Src xor (1 shl Bit); end; Здесь происходит следующее:
Сначала мы рассчитываем позицию бита - (1 shl Bit), затем с помощью операции XOR переключаем бит, а результат возвращаем результат через предопределенную переменную Result.
Пример использования: DummyValue := InvertBit(DummyValue, 2);
| Разряды | B7 | B6 | B5 | B4 | B3 | B2 | B1 | B0 |
| До (1) | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| До (2) | 1 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| После | 1 | 0 | 0 | 1 | 1 | 1 | 0 | 1 |
Проверка бита
Для проверки бита используется операция AND и анализ результата на равенство нулю. if Value and (1 shl N) <> 0 then ... установлен if Value and (1 shl N) = 0 then ... не установлен чаще всего это используется в другой форме, вместо расчета позиции используется именованная константа, например const B2 = 4 // B2 (1 shl 2) Begin if Value and B2 = B2 then ... установлен if Value and B2 = 0 then ... не установлен end; Это более наглядно, особенно если константе дано более значимое имя, чем B2, например, для проверки готовности передатчика мы можем определить константу с именем TxReady, тогда это будет выглядеть очень красиво. const TxReady = 4 Begin if Value and TxReady then begin ... обработка готовности передатчика end; end;
Ну, вот с базисом мы покончили и пора приступить к более полезным и практическим примерам. В качестве примера выберем поиск папок и файлов. Пример был разработан для FAQ конференции fido7.ru.delphi, в дальнейшем был немного модернизирован по замечаниям от Юрия Зотова. Полный пример и остальные статьи из FAQ доступны для загрузки с моего .
procedure ScanDir(StartDir: string; Mask:string; List:TStrings); var SearchRec : TSearchRec; begin if Mask = '' then Mask := '*.*'; if StartDir[Length(StartDir)] <> '\' then StartDir := StartDir + '\'; if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then begin repeat Application.ProcessMessages; if (SearchRec.Attr and faDirectory) <> faDirectory then List.Add(StartDir + SearchRec.Name) else if (SearchRec.Name <> '..') and (SearchRec.Name <> '.') then begin List.Add(StartDir + SearchRec.Name + '\'); ScanDir(StartDir + SearchRec.Name + '\', Mask, List); end; until FindNext(SearchRec) <> 0; FindClose(SearchRec); end; end; Рассмотрим ключевые моменты, относящиеся к данной статье. if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then
Здесь является битовой маской, описанной в модуле SysUtils, ее значение равно $3F, она предназначена для включения в поиск специальных файлов и одновременно для изоляции лишних бит из структуры TsearchRec, отдельные биты данной маски описаны как именованные константы.
| Наименование | Значение | Описание | |
| FaReadOnly | $00000001 | Read-only files | Файлы с защитой от записи |
| faHidden | $00000002 | Hidden files | Невидимые файлы |
| faSysFile | $00000004 | System files | Системные файлы |
| faVolumeID | $00000008 | Volume ID files | Метка тома |
| faDirectory | $00000010 | Directory files | Папки |
| faArchive | $00000020 | Archive files | Архивные файлы (для системы архивации) |
| faAnyFile | $0000003F | Any file | Все файлы - комбинация выше указанных флагов |
здесь мы видим проверку флага faDirectory, работает это следующим образом, сначала изолируются не нужные биты, затем проводится проверка на неравенство нулю, поскольку все остальные биты изолированы, то возможны только два значения, ноль, если флаг не установлен и не ноль установлен, в зависимости от результата выполняется, или часть THEN, или часть ELSE. Других вещей касаемо нашей статьи в примере нет и поэтому рассматривать больше нечего. Прочие логические операции работают с булевыми, а не с битовыми значения.
В заключение статьи можно еще привести примеры использования масок для изоляции битов и выполнения операций над оставшимися битами, возьмем для примера какую ни будь абстрактную комбинацию бит и выполним, что ни будь с ними.
Например, у нас есть такая структура некоторого устройства, и при поступлении данных происходит прерывание, обработка которого поступает в наш обработчик и в другие вместе с кодом состояния, если мы обработали сообщение, то мы должны возвратить значение TRUE, если то FALSE и тогда управление будет передано следующему в цепочке обработчику. Бит TxReady проверять не надо, управление будет поступать, только тогда когда он установлен.
abcccddd - где
Ошибки при работе с битами
На этом статья закончена и вы смогли получить начальные сведения по выполнению логических операций с битами, в заключении приведу и таблицу весовых коэффициентов, чтобы было легче рассчитывать константы.
Приложения
Таблица весовых множителей для 32 битного числа
| 0 | 1 | 1 | 8 | 256 | 100 | 16 | 65536 | 10000 | 24 | 16777216 | 1000000 |
| 1 | 2 | 2 | 9 | 512 | 200 | 17 | 131072 | 20000 | 25 | 33554432 | 2000000 |
| 2 | 4 | 4 | 10 | 1024 | 400 | 18 | 262144 | 40000 | 26 | 67108864 | 4000000 |
| 3 | 8 | 8 | 11 | 2048 | 800 | 19 | 524288 | 80000 | 27 | 134217728 | 8000000 |
| 4 | 16 | 10 | 12 | 4096 | 1000 | 20 | 1048576 | 100000 | 28 | 268435456 | 10000000 |
| 5 | 32 | 20 | 13 | 8192 | 2000 | 21 | 2097152 | 200000 | 29 | 536870912 | 20000000 |
| 6 | 64 | 40 | 14 | 16384 | 4000 | 22 | 4194304 | 400000 | 30 | 1073741824 | 40000000 |
| 7 | 128 | 80 | 15 | 32768 | 8000 | 23 | 8388608 | 800000 | 31 | 2147483648 | 80000000 |
6 сентября 2003 года
Примечание:
Статья написана специально для , как эксклюзивный материал, использование данной статьи на других сайтах разрешено только по получению особого разрешения от
Для разработки архива использован PHP 4.3.5, разработка скрипта
в Паскале была собственная поддержка
Введение
Еще с древних времен в Паскале была собственная поддержка файлов, а к тому времени, когда мамонты уже вымерли, в нем появилась поддержка работы с файлами через ОС, а когда наши предки уже научились добывать огонь, появилась VCL.
В современной литературе работа с файлами Паскаль или совсем не рассматривается или рассматривается в скользь. В тоже время поддержка файлов в Паскале достаточно высоко уровневая и значительно превосходит то, что предоставляется средствами ОС и VCL, в которых работа абстрагирована от типов в сторону работы с абстрактными байтами. Это выражается в поддержке работы с текстовыми файлами и в наличии поддержки работы с типами, не в даваясь в подробности реализации на уровне операционной системы. Правда VCL поддерживает загрузку и разбор файлов определенного типа в объекты списков, графических образов и других типов объектов, но не включает поддержки строк и типов.
Сочетание этих двух средств позволяет получить хорошие результаты. Данная статья затрагивает использование только файлов Паскаль и немного затронет VCL. Основное ее назначение помочь начинающим освоить этот вид работы с файлами, а работа с VCL вполне достаточно описана в современной литературе, да и сама по себе она простая.
Статья разбита на главы с объяснением по каждому отдельному направлению и будут использованы практические, а не абстрактные примеры. Статья состоит из пяти основных глав.
Работа с файлами Паскаля едина для трех основных типов файлов и очень простая. Ведется она через файловую переменную, одного из трех типов, к которой применяются функции и процедуры. Типовая последовательность следующая:
С уважением,
Анатолий Подгорецкий
06..13 сентября 2003 года
Примечание:
Статья написана специально для Королевства Дельфи, как эксклюзивный материал, использование данной статьи на других сайтах разрешено только по получению особого разрешения от Королевства Дельфи
Для разработки архива использован PHP 4.3.5, разработка скрипта
Для начала разберемся, что такое
Для начала разберемся, что такое текстовые файлы и в чем их различие от двоичных файлов. Текстовые файлы являются подмножеством двоичных файлов, но в отличие от двоичных не могут содержать весь набор символов. Вся информация в файле разбивается на строки, ограниченные символам возврат каретки (CR) и перевод строки (LF). Допустимые символы это символы с кодами от 32 до 255, символы с кодами ниже 32 являются управляющими и допустимы только следующие коды:
Такая ситуация сложилась в стародавние время, когда устройством вывода были телетайпы, затем пишущие машинки и потом появились дисплеи. А каналы связи не позволяли передавать двоичные данные, да и сам они были сначала 5 битные, затем 7 битные и только потом таблицу символов расширили до 8 бит, для поддержки национальных языков и для полной совместимости с компьютерами, где основной единицей был байт. Остальные коды использовались или для управления каналом передачи или для управления специальными устройствами.
Паскаль поддерживает работу с такими файлами, через файловую переменную типа TextFile, где основной единицей является строка, состоящая из основных базовых типов (в текстовом виде, разделенных пробелом), наиболее часто это просто строка, как набор символов. В качестве примера напишем программу преобразования из DOS кодировки (OEM) в Windows (ANSI).
Техническое задание:
Текст программы
Program Oem2Ansi;
{$APPTYPE CONSOLE}
uses
Windows,
SysUtils;
var
InFile: TextFile;
OutFile: TextFile;
InFilename: string;
OutFilename: string;
S: string;
begin
if ParamCount = 0
then
begin
WriteLn('Syntax is: Oem2Ansi Infile [outfile]');
Halt(1); // Ошибка синтаксиса
end;
InFilename := ParamStr(1);
if ParamCount = 2
then
OutFileName := ParamStr(1)
else
OutFileName := ChangeFileExt(InFilename, '.ans');
AssignFile(InFile, InFilename); // связываем входной файл
AssignFile(OutFile, OutFilename); // и выходной выходной файл
try
try
Reset(InFile); // открываем входной файл
Rewrite(OutFile); // создаем выходной файл
while not EOF(InFile) do // крутим пока не конец файла
begin
Readln(Infile, S); // читаем строку
if Length(S) > 0 // на вход функции можно
then // подавать только не пустые строки
begin
OemToChar(Pchar(S), Pchar(S));
WriteLn(Outfile, S); // записываем строку
end
else
begin
WriteLn(Outfile); // записываем пустую строку
end;
end;
except
Halt(2); // любая ошибка
// не удалось преобразовать файлы
end;
finally
CloseFile(InFile);
CloseFile(OutFile);
end;
end.
Разберем работу программы по кусочкам. Вначале объявляются две файловые переменные текстового типа и две переменные для имен файлов, а также одна переменная для хранения и обработки строки. Затем анализируются входные параметры, если параметры не указываются, то выводится сообщение об ошибки и программа заканчивается с кодом выхода 1. Обратите внимание на форму процедуру WriteLn, если в параметрах не указывается файловая переменная, то вывод производится на консоль, что удобно для выдачи различных сообщений, данная форма возможна только для консольного приложения и не применима в GUI приложении.
После этого первый параметр копируется в переменную InFilename, если параметров два, то второй параметр копируется в переменную OutFilename, иначе используется имя входного файла и изменяется расширение, на расширение по умолчанию .ANS
После этого имена файлов связываются с файловыми переменными. Теперь мы готовы к преобразованию файла, которое будет делаться в двух защищенных блоках, первый блок для защиты ресурсов, а второй блок для защиты от возможных ошибок при работе с файлами, для любых ошибок возвращается код ошибки 2.
Первое действие состоит в открытии файлов, входной файл открывается с помощью процедуры Reset - это открытие текстового файла в режиме чтения, а второй с помощью Rewrite – открытие в режиме записи, если файл существует, то он переписывается. Есть еще одна форма открытия текстовых файлов, это функция Append(FileVar), открытие в режиме добавления строк, если файл существует, то курсор позиционируется в конец файла и файл открывается в режиме записи, если файла нет, то он создается. После нее управление передается в блок finally. В случае ошибки управление сначала передается в блок except, а затем в блок finally.
После этого создается цикл чтения строк, пока не будет достигнут конец файла, или физический или будет встречен символ EOF. Функция EOF(FileVar).
Внутри цикла читается строка во временную переменную Readln(Infile, S) и тут принята одна предосторожность, в функцию Oem2Char НЕЛЬЗЯ передавать пустые строки, поэтому производится анализ длины строки, если строка не нулевая, то производится конвертирование и запись ее в выходной файл, процедурой WriteLn(Outfile, S), иначе в файл пишется пустая строка.
По окончанию цикла или в случае ошибки управление поступает в защищенный блок finally, где оба файла закрываются и управление передается операционной системе.
Домашнее задание - переписать в Ansi2Oem для выполнения обратной функции, с тем же техническим заданием, расширение по умолчанию OEM
Для особо желающих предлагается сделать GUI версию, с диалогами выбора файлов, с прогресс-бар, с предварительным просмотром первых 10-20 строк входного файла (переключение кнопкой OEM/ANSI), с целью определения направления перекодирования, с остальными наворотами, которые сумеет придумать душа, например пакетная обработка всех файлов из папки.
Для разработки архива использован PHP 4.3.5, разработка скрипта
Второй тип файлов, для которого
Второй тип файлов, для которого нет поддержки в OS и VCL – это типизированные файлы. Это такой вид файлов, в котором содержатся записи одного типа и фиксированной длины. Часто используется или для организации мини баз, конфигураций, иногда для импорта/экспорта в специальных форматах. Работа с такими файлами не сложнее, чем работа с текстовыми файлами, наряду с освоенными методами добавляется только одно новое свойство. Если текстовые файлы чисто последовательные, то в типизированных файлах можно перемещаться на любую запись и затем производить последовательное чтение или запись. Это очень похоже на работу с TFileStream за одним исключением, единицей информации является не байт, а тип.
Типизированный файл определяется следующим образом
var
FileVar: file of тип;
Где тип это или предопределенный или пользовательский типы. В качестве типов не могут фигурировать динамические структуры, такие как динамические массивы, длинные строки или любые указатели, поскольку все записи должны быть одинаковой длины и не должны указывать на внешние данные. Для обработки таких данных надо использовать не типизированные файлы.
Наряду с ранее указанными процедурами нам надо знать еще об некоторых функциях, это процедура Seek, которая не применима для текстовых файлов, а для типизированных файлов используется для перемещения указателя на нужную запись.
Для определения количества записей в файле можно использовать функцию FileSize, которая возвращает именно количество записей, а не длину файла, как это следует из ее названия.
Для определения текущей позиции в файле можно использовать функцию FilePos.
Для уменьшения длины файла можно использовать процедуру Truncate, которая обрезает файл по текущей позиции
Замечания по поводу открытия файлов, для этого используются две ранее описанные процедуры: Rewrite - создает новый файл для чтения/записи, если такой файл существует, его длина устанавливается в ноль, а Reset - открывает файл для чтения/записи и не изменяет его длины. Сразу видно различие в этих процедурах по отношению к текстовым файлам.
Примечание: записи считаются с нуля
Для примеров возьмем любимую в ранних книгах по Паскалю, где в качестве примера использовался пример реализации телефонного справочника с помощью типизированных файлов или же подобные примеры для хранения персональных записей. Эту основу мы будем использовать и в других главах. Для этого определим следующий тип:
type
TPhoneRec = packed record
PersonName: string[25];
Address: string[25];
Phone: string[16];
end;
Теперь переходим к демонстрационному примеру, определения типа повторять не будем. Напишем только основные функции работы с файлом, а визуализацию самих данных оставим за бортом, но для самой визуализации очень хорошо подходит TStringGrid.
Примеры работы с типизированными файлами
// опредение глобальных для модуля или программы переменных
var
PersonFile: file of TPhoneRec; // определили файл нашего типа
DbOpen: Boolean; // флаг состояния базы
PhonesCount: Integer; // количество записей в базе
// открытие базы и нициализация
// не пытаться работать с базой если результат = FALSE
function OpenDB(const DbName: string): Boolean;
begin
AssignFile(PersonFile, DbName);
try
Reset(PersonFile); // открываем базу
PhonesCount := FileSize(PersonFile); // текущее кол. записей
DbOpen := TRUE; // открытие прошло нормально
except
PhonesCount := 0;
DbOpen := FALSE;
end;
Result := DbOpen;
end;
// создание новой базы и инициализация
// не пытаться работать с базой если результат = FALSE
function CreateDB(const DbName: string): Boolean;
begin
AssignFile(PersonFile, DbName);
try
Rewrite(PersonFile); // открываем базу
DbOpen := TRUE; // открытие прошло нормально
except
DbOpen := FALSE;
end;
PhonesCount := 0; // записей нет
Result := DbOpen;
end;
// закрытие базы
procedure CloseDB;
begin
if DbOpen
then
CloseFile(PersonFile);
end;
// Удалить все после указанной записи
procedure TruncateDB(const RecNo: Integer);
begin
Seek(PersonFile, RecNo);
Truncate(PersonFile);
end;
// Читать следующую запись
function ReadNextRec: TPhoneRec;
begin
Read(PersonFile, Result);
end;
// Читать указанную запись
function ReadRec(const RecNo: Integer): TPhoneRec;
begin
Seek(PersonFile, RecNo);
Result := ReadNextRec;
end;
// изменить текущую запись
procedure ModifyNextRec(const Rec: TPhoneRec);
begin
Write(PersonFile, Rec);
end;
// изменить указанную запись
procedure ModifyRec(const RecNo: Integer; const Rec: TPhoneRec);
begin
Seek(PersonFile, RecNo);
ModifyNextRec(Rec);
end;
// Добавить новую запись в конец файла
procedure AddRec(const Rec: TPhoneRec);
begin
Seek(PersonFile, PhonesCount); // переместиться на последнею запись
ModifyNextRec(Rec); // и добавить запись
PhonesCount := FileSize(PersonFile); // новое кол. записей
end;
Попробуем воспользоваться написанными функциями и для этого попробуем загрузить все записи в динамический массив.
program ReadPhoneBook;
{$APPTYPE CONSOLE}
uses
PhoneDb;
var
I: Integer;
PhoneEntry: TPhoneRec; // отдельная запись
PhoneBook: array of TPhoneRec; // телефонный справояник
begin
if not CreateDB('C:\DB\Phones.dbf') then Exit;
WriteLn('Created C:\DB\Phones.dbf');
for I := 0 to 3 do
begin
PhoneEntry.PersonName := 'PersonName ' + IntToStr(I);
PhoneEntry.Address := 'Address ' + IntToStr(I);
PhoneEntry.Phone := '(012) 3456789-' + IntToStr(I);
AddRec(PhoneEntry);
WriteLn(PhoneEntry.PersonName,' ',
PhoneEntry.Address,' ' ,
PhoneEntry.Phone);
end;
CloseDB;
WriteLn('Check database');
if OpenDB('C:\DB\Phones.dbf')
then
begin
SetLength(PhoneBook, PhonesCount);
for I := 0 to PhonesCount - 1 do
begin
PhoneBook[I] := ReadNextRec;
WriteLn(PhoneBook[I].PersonName,' ',
PhoneBook[I].Address,' ' ,
PhoneBook[I].Phone);
end;
end;
WriteLn('Press ENTER to exit');
ReadLn;
end.
Конечно, вместо использования процедур и функций, лучше это оформить в виде классов и иметь все преимущество от использования ООП, но в учебных целях это сделано именно так.
Для разработки архива использован PHP 4.3.5, разработка скрипта
Третий тип файлов Паскаля, это
Третий тип файлов Паскаля, это нетипизированные файлы, этот тип характеризуется тем, что данные имеют не регулярную структуру, например записи различных типов или записи переменной длины, или это просто двоичные данные.
После появления поддержки файлов в VCL, на уровне потоков, а также прямой доступ к файловой системе, через функции АПИ, его ценность стала низкой и почти во всех случаях правильнее использовать потоковые методы из VCL, и только тогда когда требуется небольшой размер программы, стоит использовать их или Win API.
Хотя предполагается работа с двоичными данными неопределенного типа, все равно ведется работа с понятиями запись (блок), размер которой задается при открытии файла, по умолчанию размер записи равен 128 байт. Размер файла должен быть кратным размеру блока, иначе при чтении последней записи возникнет ошибка.
Новых понятий немного, это понятие размер блока, режим открытия и вместо процедур Read/Write используются процедуры BlockRead/BlockWrite.
Посмотрим на изменения по отношению к текстовым и типизированным файлам.
Объявление файла делается так:
var
FileVar: file;
Сразу бросается в глаза отсутствие типа, вместо file of тип, просто file, то есть файл данных любого типа.
Функции открытия файла Reset и Rewrite имеют дополнительный параметр, который указывает размер записи, если этот параметр не указан, то используется значение по умолчанию в 128 байт, кстати, это часто является одной из причин для возникновения ошибок, забываем указать этот размер, а при работе считаем, что работаем с байтом. Что бы работать с файлом, как с байтом, надо или установить размер записи в 1 или использовать типизированный файл следующего типа - file of byte.
При получении размера файла, результат выдается так же в записях, и если опять же нужно получить размер файла в байтах, также надо устанавливать размер записи в единицу или умножить количество записей на размер записи, в этом кстати и состоит различие между файлами Паскаля и файлами в АПИ или VCL, те не оперируют понятиями запись, а только понятиями байт. Другая ошибка у начинающих состоит в том, что длина файла должна быть кратна длине записи, частичные записи не допустимы.
Различие между Reset и Rewrite такое же, как и у нетипизированных файлов, первый открывает файл без уничтожения старого файла, а второй создает новый файл, режим открытия файлов задается отдельно.
Примеры открытия файла с размером записи в 1 байт
Reset(F, 1); // открытие с сохранением файла, файл должен существовать
Rewrite(F, 1); // открытие с созданием нового файла, или с удалением старого
Для управления режимом открытия файлов существует глобальная переменная FileMode. Назначение этой переменной одного из значений влияет на режим последующего открытия файлов, все последующие файлы открываются в соответствии с ее значением, режим ранее открытых файлов не изменяется. Данная переменная не применима для текстовых файлов, которые открываются в соответствии с типом функции, для Reset это режим только чтение, для Rewrite и Append это режим записи.
В модуль Sysutils находится определение констант для потоков, часть констант совпадает с нужными нам. Для полноценного управления режимами доступа надо использовать класс TFileStream.
FmOpenRead = 0 открытие только в режиме чтения
FmOpenWrite = 1 открытие только в режиме записи
fmOpenReadWrite = 2 открытие в режиме чтения/записи
Примечание: Переменная FileMode не является потоко безопасной.
Теперь можно приступить к примерам и поскольку трудно придумать практический пример, то я приведу по три основных примера использования данного типа и с использованием TFileStream. Это позволит оценить оба метода.
Пример 1 - абстрактные данные (file)
Использование с двоичными данными абстрактного типа. Просто набор байт.
Для демонстрации возьмем простой набор строк, скажем из TStringList. Запись в файл будем производить в следующем формате - длина, строка.
Особого практического применения нет, но данная техника часто используется в потоках. Когда надо передавать данные переменной длины, записывающий поток передает, принимающий поток сначала считывает длину, а затем считывает уже известное количество данных.
Умолчания для примера:
1. SL создан и содержит строки;
2. Переменная FileName инициализирована и содержит имя файла;
3. Обработка ошибок не ведется, кроме необходимых случаев.
var
SL: TStringList;
I: Integer;
F: file;
FileName: string;
begin
try
AssignFile(F, Filename); // связали файл с переменной
FileMode := fmOpenWrite; // только запись
Rewrite(F, 1); // размер записи один байт
for I := 0 to Sl.Count –1 do // проход по всем строкам
bеgin
BlockWrite(F, Length(Sl.Strings[I]), SizeOf(LongInt));
BlockWrite(F, Sl.Strings[I], Length(Sl.Strings[I]);
end;
finally
CloseFile(F);
end;
end.
Пример 2 - абстрактные данные (TFileStream)var
SL: TStringList;
I: Integer;
FS: TFileStream;
FileName: string;
I: Integer;
begin
FS := TFileStream.Create(Filename, fmOpenWrite or fmShareExclusive);
try
for I := 0 to Sl.Count –1 do // проход по всем строкам
bеgin
FS.Write(Length(Sl.Strings[I]), SizeOf(LongInt));
FS.Write(Sl.Strings[I], Length(Sl.Strings[I]));
end;
finally
FS.Free;
end;
end.
Преимущество состоит в использовании расширенных режимов открытия файлов и нет нужды объявлять размер записи, поскольку самих записей не существует, при записи в файл просто указывается длина данных.
Пример 3 – записи фиксированной длины (file)
Использование записей, но разного типа. Обратите внимание, что в записях используется не Integer, а LongInt, это связано с тем, что Integer не является фундаментальным типом и его размер зависить от версии компилятора, в то же время LongInt всегда 4 байта. Также что размер string[3] совпадает с размером LongInt, этим обеспечивается одинаковый размер записи. Вторым параметром, влияющим на размер записи - являет выравнивание элементов записи, на какую либо границу 2, 4 8 байт, это также предмет для изменений в различных версиях компилятора или его настроек. Использование ключевого слова packed позволяет избежать этой неприятности, в этом случае запись занимает ровно столько место, сколько требуется и не байтом больше. Это обеспечит нам переносимость. Настоятельно рекомендую обратить особое внимания на эти замечания, поскольку это распространенная ошибка при написании программ.
Умолчания для примера:
1. Массив DevArray создан и содержит данные;
2. Переменная FileName инициализирована и содержит имя файла;
3. Обработка ошибок не ведется, кроме необходимых случаев.
type
TCmd: string[3]; // команда устройству, аббревиатура из 3 символов
TRecType = (rtNone, rtCmd, ctData);
THdr = packed record
TypeID: TRecType; // идентификатор записи,
// общая часть во всех остальных типах.
end;
TCmd = packed record
Hdr: THdr; // идентификатор записи
DevCmd: TCmd; // команда устройству, аббревиатура из 3 символов
end;
TData = packed record
Hdr: THdr; // идентификатор записи
DevData: LongInt; // данные для устройства или из устройства
end;
TDevEntry = packed record
Cmd: TCmd;
Data: LongInt;
end;
var
Cmd: TCmd;
Data: Tdata;
DevArray: array[1..100] of TDevEntry;
F: file;
FileName: string;
I: Integer;
begin
try
AssignFile(F, Filename); // связали файл с переменной
FileMode := fmOpenWrite; // только запись
Rewrite(F, SizeOf(TCmd)); // TData имеет тот же размер
for I := Low(DevArray) to High(DevArray) do // проход по массиву
bеgin
Cmd.Hdr.TypeID := rtCmd;
Cmd.DevCmd := DevArray[I].Cmd;
BlockWrite(F, Cmd, SizeOf(TCmd));
Data.Hdr.TypeID := rtData;
Data.DevData := DevArray[I].Data;
BlockWrite(F, Data, SizeOf(TData));
end;
finally
CloseFile(F);
end;
end.
Пример 4 – записи фиксированной длины (TFileStream)
Объявления типов прежние.
var
DevArray: array[1..100] of TDevEntry;
FS: TFileStream;
I: Integer;
begin
FS := TFileStream.Create(Filename, fmOpenWrite or fmShareExclusive);
try
for I := Low(DevArray) to High(DevArray) do // проход по массиву
bеgin
FS.Write(rtCmd, SizeOf(THdr.TypeID));
FS.Write(DevArray[I].Cmd, SizeOf(TCmd.DevCmd));
FS.Write(rtData, SizeOf(THdr.TypeID));
FS.Write(DevArray[I].Data, SizeOf(TData.DevData));
end;
finally
FS.Free;
end;
end.
Как только код стал сложнне, так сразу стало видно, что использование TFileStream проще и прозрачнее, код более четкий. Отпала необходимости в копировании данных во временные переменные.
Пример 5 - записи переменной длины (file)Использование записей переменной длины для организации сложных структур. Записи состоят из двух частей, фиксированной с информацией о дальнейших записях и переменной 0 сами записи. Возможно построение сложных иерархических структур, когда одна запись содержит в себе другие вложенные данные, наглядным примером являются объектовые (.obj) и исполнимые файлы (.exe).
Умолчания для примера:
1. Массив DevArray создан и содержит данные;
2. Переменная FileName инициализирована и содержит имя файла;
3. Обработка ошибок не ведется, кроме необходимых случаев.
В качестве основы определим следующие типы:
type
THdr = packed record
RecID: TRecType; // идентификатор записи, необязательная часть,
// зависит от задачи,
// но очень полезная в сложных структурах
RecLg: Integer; // длина данных, следуют сразу за заговоком
// данные могут быть простыми, но также и сложными
// то есть включать другие структуры
// со своими заголовками
end;
TCmd = string[6];
TPacked = packed record
DevCmd: TCmd; // команда устройству, аббревиатура из 3 символов
DevData: string; // переменная длина
end;
TDevEntry = packed record
Cmd: TCmd;
Data: string;
end;
В файл будем писать данные в следующим формате
1. Заголовок типа THdr, В качестве RecID будем использовать порядковый номер записи начиная с 1. RecLg будет включать полную длину последующего пакета, размер которого переменный.
2. Данные в формате TPacked, где DevCmd аббревиатура команды из 6 символов (string[6]), фиксированной длины и строковые данные переменной длины. Общая длина пакета отражается в заголовке записи, в поле RecLg.
var
Hdr: THdr;
DevArray: array[1..100] of TDevEntry;
F: file;
FileName: string;
I: Integer;
begin
try
AssignFile(F, Filename); // связали файл с переменной
FileMode := fmOpenWrite; // только запись
Rewrite(F, 1); // так как записи переменной длины,
// то размер записи 1 байт
for I := Low(DevArray) to High(DevArray) do // проход по массиву
bеgin
Hdr.RecId := I;
Hdr.RecLg := SizeOf(TCmd) + Length(DevArray[I].Data);
BlockWrite(F, Hdr, SizeOf(THdr)); // записали заголовок
BlockWrite(F, DevArray[I].Cmd, SizeOf(TCmd));
BlockWrite(F, DevArray[I].Data[0], Length(DevArray[I].Data);
end;
finally
CloseFile(F);
end;
end.
В примере происходит следующее:
Цикл повторяется по всему массиву, по окончанию файл закрывается, теперь реализуем это пример с помощью TFileStream.
Пример 6 - записи переменной длины (TFileStream)
var
DevArray: array[1..100] of TDevEntry;
FS: TFileStream;
I: Integer;
begin
FS := TFileStream.Create(Filename, fmOpenWrite or fmShareExclusive);
try
for I := Low(DevArray) to High(DevArray) do // проход по массиву
bеgin
FS.Write(I, SizeOf(THdr.RecID));
FS.Write(SizeOf(TCmd)+Length(DevArray[I].Data),SizeOf(THdr.RecLg));
FS.Write(DevArray[I].Cmd, SizeOf(TCmd));
FS.Write(DevArray[I].Data[0], Length(DevArray[I].Data);
end;
finally
FS.Free;
end;
end.
Опять видим, что код стал проще и прозрачнее. Отпала необходимость во временных переменных.
На этом данный урок закончен, в принципе Вы уже должны представлять основные методы работы с тремя базовыми файлами и начальные сведенья по TFileStream, что позволит сделать выбор в сторону правильного для задачи метода.
Для разработки архива использован PHP 4.3.5, разработка скрипта
с текстовыми файлами Расширенная работа
Кроме работы со строками в текстовых файлах, Паскаль поддерживает и более расширенные методы, можно оперировать и данными в строке. Можно читать данные из строки в одну или более переменных. Паскаль сам обеспечивает разбор строки на составляющие части.
Полный синтаксис процедур следующий
procedure ReadLn([ var F: TextFile; ] V1 [, V2, ...,Vn ]);
procedure WriteLn([ var F: TextFile; ] P1 [, P2, ...,Pn ] );
Кроме того, справка полностью умалчивает о формате вывода данных в файл, о возможности форматирования данных непосредственно в параметрах процедуры. Форматирования вывода осуществляется в следующем виде X [:Width [:Decimals]], где Width общая длина вывода, а Decimals это количество знаков после десятичной точки. Для получения нужной длины вывода слева добавляется нужное количество пробелов, если результат не помещается в указанную длину, то тогда длина увеличивается до должного количества знаков.
Спецификатор Decimals применим только к числам с плавающей запятой. При этом при необходимости производится округление числа. Если спецификаторы не указаны, то для вывода используется научный формат, то есть #.##############E+####
Для целочисленных чисел, строк и символов, без указания длины используется столько символов, что бы значение полностью вывелось.
Значения выводятся без разделителей между ними, поэтому надо или использовать длину на один символ больше нужной или вставлять в список параметров пробел, например так
Writeln(F, A,' ',B,' ',C);
Теперь по поводу чтения обратно в переменные. Все аналогично выводу, за исключением одного неприятного отличия. В случае указания в списке переменных, переменной строкового типа, в нее считывает все до окончания строки. Вроде в старом Паскале такого не было, там вроде бы считывалось слово до первого разделителя, но так ли это было уже не помню, но это и не важно, важно знать как это работает сейчас и учитывать это при чтении данных. Поэтому если надо считывать элементы строки в переменные, то можно использовать только один элемент и он должен быть последним в строке. Приведу пример неправильной логики.
WriteLn(F, 1, ' ', 2.5:3:1, ' ', ‘string’, ' ', 3);
ReadLn(F, Int1, Real1, Str1, Int2);
В файле будет следующая информация
1 2.5 string 3
После считывания значения переменных следующие:
Int1 = 1
Real1 = 2.5
Str1 = string 3
Int2 = 0
Правильно написать так
WriteLn(F, 1, ' ', 2.5:3:1, ' ', 3, ' ', ‘string’);
ReadLn(F, Int1, Real1, Int2, Str1);
Теперь в переменных правильные значения:
Int1 = 1
Real1 = 2.5
Int2 = 3
Str1 = string
Ну и на последок напишем простой пример чтения и записи двухмерного массива в файл.
var
Column: Integer;
F: TextFile;
IntArray: array[1..10, 1..3] of Integer;
Row: Integer;
S: string;
TmpInt: Integer;
begin
// Инициализация
for Row := 1 to 10 do
begin
for Column := 1 to 3 do
begin
IntArray[Row, Column] := Row*100 + Column;
end;
end;
AssignFile(F, 'Test.txt');
try
Rewrite(F); // открытие для записи
for Row := 1 to 10 do
begin
for Column := 1 to 3 do
begin
Write(F, IntArray[Row, Column]:11);
end;
WriteLn(F, ' Строка: ', Row);
end;
finally
CloseFile(F);
end;
// Чтение
try
WriteLn('Test Reading');
Reset(F); // открытие для чтения
for Row := 1 to 10 do
begin
for Column := 1 to 3 do
begin
Read(F, TmpInt);
Write(TmpInt:11);
end;
ReadLn(F, S);
WriteLn(S);
end;
finally
CloseFile(F);
end;
Readln; // Закрытие окна по ENTER
end.
После проверки, можете открыть файл Блокнотом и убедиться, что он действительно текстовый.
Примечание: при выводе текстовых сообщений учтите, что на консоль надо выводить в OEM кодировке, поэтому если надо вывести текст на национальном языке, то предварительно преобразуйте его из ANSI в OEM, см. главу «Текстовые файлы - домашнее задание». То есть, любой текст надо преобразовывать функцией CharToOem. Это же касается и текстовых констант в коде программы.
Для разработки архива использован PHP 4.3.5, разработка скрипта
Использование текстовых файлов для импорта
Текстовые файлы являются универсальным средство импорта/экспорта, например, Excel может очень легко импортировать текстовые файлы, в одном из распознаваемых им форматов. Допустимы следующие форматы:
Все четыре формата имеют свое назначение, по умолчанию CSV формат считается универсальным форматом, поскольку многие программы и даже некоторые языки программирования поддерживают его. Недостатком является некоторая избыточность. Самые экономные это Tab delimited и Symbol Delimited, поскольку для разделение используется только один символ. Самый не экономный формат Fixed, поскольку для размещения данных всегда используется полная длина, его достоинством является простота обработки файла, можно просто читать фиксированными порциями или даже определить структуру в программе. Многие программы пишут свои логи именно в этом формате.
Какой использовать формат определяется задачей. Но я рассмотрю в примерах все форматы. Данные для экспорта могут находиться где угодно: в базе данных, в TStringList, в другом текстовом файл, поступать из потока. В примерах будет использоваться экспорт из TStringGrid, это позволит нам убить двух зайцев, дополнить возможности TStringGrid и освоить экспорт. В дополнение к примерам по экспорту, я рассмотрю и обратную операцию, загрузку данных в TstringList из ранее сохраненных данных в текстовой файл.
Пример 1, экспорт в файл в формате Comma Separated ValueОсновой для экспорта в CSV понимание некоторых вещей:
1. Первая строка должна быть строкой заголовков колонок;
2. Данные разделяются запятой;
3. Числовые данные пишутся, как есть;
4. Строковые данные заключаются в двойные кавычки;
5. Даты распознаются если они в формате MM/DD/YYYY, заключать в кавычки не надо;
6. Расширение файла должно быть CSV.
Будьте осторожнее, обратный экспорт из Экселя работает не так как ожидается, формат далек от CSV, для обратного экспорта правильнее использовать формат Tab Delimited, с ним не ожидается таких сложностей и странностей. Есть еще странности, например, очень отличаются по действию открытие этих файлов из меню и открытие по ассоциации с расширением. Результаты очень удивят. Попробуйте поэкспериментировать с файлами и с Экселем, только сохраняйте в файлы с различными именами. При открытии по ассоциации (двойной щелчок) и расширении CSV получается полностью автоматический импорт.
Умолчания для примера:
1. StringGrid создан и содержит некоторое количество колонок и строк, количество определяется при экспорте;
2. Информация о типах данных в колонках StringGrid, то будем считать, что первая колонка целое число, вторая это дата в региональном формате и третья колонка это текст, больше колонок у нас нет.
3. Количество строк зависит от наполнения.
4. Нулевая строка как обычно содержит заголовки колонок.
5. Переменная FileName инициализирована и содержит имя файла, с должным расширением;
6. Обработка ошибок не ведется, кроме необходимых случаев.
var
F: TextFile;
FileName: string;
I: Integer;
SG: TStringGrid;
TempStr: string;
Y, M, D: Word;
begin
try
AssignFile(F, Filename); // связали файл с переменной
Rewrite(F); // создаем пустой файл
// если строка с заголовком не нужна, то можно эту строку удалить.
WriteLn(F,
'"', SG.Cells[0, 0], '",',
'"', SG.Cells[1, 0], '",',
'"', SG.Cells[2, 0], '"');
for I := 1 to SG.RowCount – 1 do // проход по всем строкам
begin
try
// конвертирование строки из регионального в американский формат
DecodeDate(StrToDate(Trim(SG.Cells[1, I])), Y, M, D);
TempStr := IntToStr(M)+'/'+ IntToStr(D)+'/'+IntToStr(Y);
except
TempStr := ' '; // дата не указана или неверная
end;
WriteLn(F,
SG.Cells[0, I], // число
TempStr, // конвертированная дата
'"', SG.Cells[2, I], '"'); // текст
end;
finally
CloseFile(F);
end;
end;
Как видим код весьма простой, первым WriteLn выводим заголовки таблицы, а поскольку все заголовки это текст, то обрамляем элементы двойными кавычками и разделяем запятой.
Далее в цикле проходим по всем строкам данных и выводим сами данные, но в отличии от строки заголовка делаем следующее:
Если дата опущена или неверная, то экспортируем пустое значение.
Пример 2, экспорт в файл в формате Tab Delimited
При выводе в данном формате преобразования не нужны, наша задача состоит в том, чтобы вставить символ табуляции между колонками данных, поэтому код будет еще проще. Заголовки и данные выводятся в едином цикле и разделяются символом табуляции.
Этот же пример пригоден и для формата Symbol Delimited, достаточно заменить символ табуляции на любой нужный символ.
Умолчания для примера:
1. StringGrid создан и содержит некоторое количество колонок и строк, количество определяется при экспорте;
2. Так как отсутствует информация о типах данных в колонках StringGrid, то будем считать, что первая колонка целое число, вторая это дата в региональном формате и третья колонка это текст, больше колонок у нас нет. Но для экспорта данная информация не нужна.
3. Количество строк зависит от наполнения.
4. Нулевая строка как обычно содержит заголовки колонок.
5. Переменная FileName инициализирована и содержит имя файла, с должным расширением;
6. Обработка ошибок не ведется, кроме необходимых случаев.
const
TAB = #9; // код символа табуляции
// константа для удобства
// можно было бы использовать и #9
var
F: TextFile;
FileName: string;
I: Integer;
SG: TStringGrid;
begin
try
AssignFile(F, Filename); // связали файл с переменной
Rewrite(F); // создаем пустой файл
// если строка с заголовком не нужна,
// то начните цикл не с нуля, а с единицы.
for I := 0 to SG.RowCount – 1 do // проход по всем строкам
begin
WriteLn(F,
SG.Cells[0, I] + TAB +
SG.Cells[1, I] + TAB +
SG.Cells[2, I]);
end;
finally
CloseFile(F);
end;
end;
Пример 3, экспорт в файл в формате FixedПри выводе в данном формате преобразования не нужны, наша задача состоит в том, чтобы сделать данные колонок одинаковой ширины, нам даже не нужны разделители для колонок, но удобнее будет их сделать в виде одного пробела, что бы можно было обрабатывать файл любым текстовым редактором. Заголовки и данные выводятся в едином цикле и как договорились будем их разделять пробелом.
Умолчания для примера:
1. StringGrid создан и содержит некоторое количество колонок и строк, количество определяется при экспорте;
2. Так как отсутствует информация о типах данных в колонках StringGrid, то будем считать, что первая колонка целое число, вторая это дата в региональном формате и третья колонка это текст, больше колонок у нас нет. Но для экспорта данная информация не нужна.
3. Количество строк зависит от наполнения.
4. Нулевая строка как обычно содержит заголовки колонок.
5. Переменная FileName инициализирована и содержит имя файла, с должным расширением;
6. Обработка ошибок не ведется, кроме необходимых случаев.
var
F: TextFile;
FileName: string;
I: Integer;
SG: TStringGrid;
begin
try
AssignFile(F, Filename); // связали файл с переменной
Rewrite(F); // создаем пустой файл
// если строка с заголовком не нужна,
// то начните цикл не с нуля, а с единицы.
for I := 0 to SG.RowCount – 1 do // проход по всем строкам
begin
WriteLn(F,
Format('%-25s %-25s %16s',
[SG.Cells[0, I], SG.Cells[0, I], SG.Cells[0, I] ]));
end;
finally
CloseFile(F);
end;
end;
Для выравнивание ширины колонок использована функция Format, вместо встроенного выравнивания WriteLn, поскольку последняя добавляет пробелы слева, а нам нужны пробелы справа. Вместо функции Format можно использовать свою функцию, или функции из других библиотек, или из Дельфи. Не важно, что использовать, важно чтобы строки были дополнены справа пробелами до нужной длины.
Разберем форматную строку
%-25.25s – Символ % это признак спецификатора формата, символ «-» означает выравнивание влево, 25 означает, что длина будет дополняться до 25 символов, а .25 означает максимальное количество символов в строке будет 25, остальные символы будут отбрасываться, символ s указывает не тип данных, в данном случае это означает, что в функцию передается строковое значение.
Количество спецификаторов не ограничено, в нашем случае их три и мы обязаны передать именно три параметра, что и делается, значения передаются как открытый массив. Символы пробелов, между спецификаторами, у нас выполняют роль разделителей колонок. На первый взгляд это сложно, но после того, как Вы освоите синтаксис этой функции, Вы сможете оценить всю ее мощь.
Пример 4, импорт и экспорт данных для TStringList
Остался еще один, последний пример, обеспечения импорта и экспорта данных из таблицы TStringList и обратно. Для этого выберем формат Tab Delimited, как очень экономичный и гибкий для нашей цели. Нам не придется бороться с их количеством, поскольку эти значения будут восстановлены автоматически. Нулевая строка будет содержать всю необходимую информацию о таблице. Единственно, что требуется обеспечить, чтобы все колонки данных в таблице имели свой заголовок.
Наша задача состоит в том, чтобы вставить символ табуляции между колонками данных. Заголовки и данные выводятся в едином цикле и разделяются символом табуляции, при импорте заголовки будут играть важную роль, по ним будет определяться количество колонок.
Умолчания для примера:
1. StringGrid создан и содержит некоторое количество колонок и строк, количество определяется во время выполнения;
2. Информация о типах данных в колонках StringGrid отсутствует, но она нам и не нужна, мы должны уметь экспортировать любую информацию.
3. Количество строк зависит от наполнения.
4. Нулевая строка как обычно содержит заголовки колонок.
5. Переменная FileName инициализирована и содержит имя файла, с должным расширением;
6. Обработка ошибок не ведется, кроме необходимых случаев.
const
TAB = #9; // код символа табуляции
// константа для удобства
// можно было бы использовать и #9
procedure Export(const FileName: string; SG: TStringGrid);
var
F: TextFile;
I: Integer;
J: Integer;
begin
try
AssignFile(F, Filename); // связали файл с переменной
Rewrite(F); // создаем пустой файл
for I := 0 to SG.RowCount – 1 do // проход по всем строкам
begin
for J := 0 to SG.ColCount – 1 do // проход по всем колонкам
begin
Write(F,SG.Cells[J, I]); // пишем отдельную ячейку
if J < SG.ColCount – 1
then
Write(F, TAB) // тогда пишем разделитель
else
WriteLn(F); // иначе закрываем строку
end;
end;
finally
CloseFile(F);
end;
end;
procedure Import(const FileName: string; var SG: TStringGrid);
var
F: TextFile;
S: string;
begin
try
AssignFile(F, Filename); // связали файл с переменной
Reset(F); // открываем файд с данными
SG.ColCount := 1; // начальные значения
SG.RowCount := 1; // количества колонок и строк
while not EOF(F) do // проход по всем строкам
begin
ReadLn(F, S); // читаем строку данных
SG.Col := 0; // проход всегда начинается с нуля
while Pos(TAB, S) > 0 do
begin // вычленение колонок
SG.Cells[SG.Col, SG.Row] := Copy(S, 1, Pos(TAB, S) - 1);
Delete(S, 1, Pos(TAB, S));
if SG.ColCount - SG.Col = 1
then
begin
SG.ColCount := SG.ColCount + 1;// нужна новая колонка
end;
SG.Col := SG.Col + 1; // следующая колонка
end;
SG.Cells[SG.Col, SG.Row] := S; // последняя колонка
SG.RowCount := SG.RowCount + 1; // добавим еще одну строку
SG.Row := SG.Row + 1; // следующая строка
end;
SG.RowCount := SG.RowCount - 1; // лишняя строка
finally
SG.FixedCols := 1; // восстанавливаем
SG.FixedRows := 1; // значение по умолчанию
CloseFile(F);
end;
end;
Рекомендация: Если необходимо сохранить ширину колонок, количество фиксированных строк и колонок или другие характеристики, то перед импортом сохраните эти значения, а после восстановите их, или установите в нужное значения. После импортирования эти параметры устанавливаются в значение по умолчанию.
В дополнение к обычной работе с файлами, можно отметить еще и следующее. Все ранее изученные нами методы пригодны для создания стандартных консольных приложений для динамических ВЕБ страниц. Для создания достаточно использования процедур ReadLn и WriteLn, если конечно этот сервер работает под управлением Windows. Это так называемые консольные CGI приложения (Standalone CGI Application).
Вот выдержка из книги доктора Боба «Интернет решения от доктора Боба», которую можно найти на моем сайте
Для начала посмотрим на стандартное "hello world" CGI приложение. Единственное, что оно должно сделать, это вернуть HTML страницу со строкой "hello, world". Перед тем как мы начнем делать это - обратим внимание на следующее: CGI приложение должно сообщить миру какой (MIME) формат оно выдает. В нашем случае это "text/html", которое мы должны указать как: content-type: text/html, и затем одну пустую строку.
Вот код нашего первого "Hello, world!" CGI приложения:
program CGI1;
{$APPTYPE CONSOLE}
begin
writeln('content-type: text/html');
writeln;
writeln('
writeln('
Если вы откомпилируете данную программу в Дельфи 2 или 3 и затем запустите ее из web браузера подключенного к web серверу, где оно записано в исполнимом виде в исполняемом каталоге таком как cgi-bin, то вы увидите текст "Hello, world!" на странице.
Заключение
Ну вот теперь вы знаете про файлы Паскаля все, ну или почти все :), остальное в ваших руках.
Для разработки архива использован PHP 4.3.5, разработка скрипта
Лицей.
Поводом для написания этих уроков послужила дискуссия на сайте об организации уроков для начинающих.Я также решил поделиться своим опытом, в основном по более старым, давно забытым темам. В конце восьмидесятых и в начале девяностых годов, в любой книжке по Паскалю можно было подробно прочитать о работе с битами, о работе с файлами, но в современной литературе эти вопросы или умалчиваются вообще или рассматриваются вскользь. Конечно подобной информации в Сети много, но ее надо еще найти.
Я напишу как минимум две статьи - битовая логика и работа с файлами Паскаля, может статей будет больше, но пока не знаю.
Статьи будут рассматривать отдельную тему с практическими примерами и надеюсь на уровне доступном для начинающих. Не знаю как получится, поскольку опыт писательской работы у меня не большой, зато есть приличный опыт работы в дискуссионных группах. Кроме того вся микропроцессорная техника и ее программирование прошли совместно с моей жизнью, начинал я с 8 разрядных машин, затем вплотную от самых первых персональных компьютеров и по текущие дни. Паскаль же от 4 версии до самой последней, а после уже Дельфи, начиная с первой версии.
Это было интересное время, все начинали с нуля, знаний и опыта у всех было мало, все учились друг у друга, в то же время начал развиваться Интернет, что позволило эффективно обмениваться знаниями. Не было обширного парка компонент, только потом развились файловые архивы уровня и Delphi Super Pages. Все это позволило наработать большой опыт и пришло время отдавать долги, что и делаю в виде серии этих статей для начинающих.
Данный сайт был выбран из за его большой популярности и есть надежда, что уроки не пропадут в безвестности в пучине форумов, также есть надежда, что ко мне и к Юрию Зотову присоединятся и другие писатели, которые смогут поделиться своим опытом с начинающими в виде практических или учебных статей. Такие люди есть и их много, только их надо расшевелить.
Статьи Королевства Дельфи
А что, Delphi + Corel Draw даже очень ничего.
| Раздел Сокровищница | абец Олег, дата публикации 10 мая 2001г. |
Надеюсь, многие сталкивались с Corel Draw? А у многих слюнки текли, что это мощнейший графический редактор и хотелось бы под него свои программы писать, к примеру, чертежи выводить? Я один из вас :)
Формат файлов *.cdr конечно, не представлю, т.к. сам его не знаю :), но как с этим зверем работать расскажу. Вычитал, что с Corel Draw можно работать только через скрипт, причем изначально я готовил файлы скриптов *.csc, а затем их запускал в самом редакторе. Рабочий инструмент для освоения - Corel Script Editor. Если Вы хотите действительно что-то написать, то он вам просто необходим, хотя бы ради того, что смотреть как Corel Draw их сам создает, ну и самое главное - дока по языку и функциям. Все замечательно, только вот скрипты медленно работают т.к. они эмитируют работу человека - т.е. кнопочки сами нажимаются, панельки меняются и т.д.
А чертеж, к примеру на котором около 3000 объектов мог загружаться и исполнятся до часу! Нет, кода это утомляет, то можно и самому посидеть - глядишь за неделю сделаешь :)
И тут я "чисто случайно" наткнулся на статейку . Оказывается можно и через OLE этот Corel Draw дергать, и как оказывается, не так уж оно и сложно. Да, совершенно верно, нужно использовать CorelDraw.Automation.xx. Я возился с 8-й версией. Забегая на перед, скажу, что тот же чертеж выводился в течении 5-10 минут.
Ну что, начнем?
var CorelDraw: Variant; … CorelDraw := CreateOleObject('CorelDraw.Automation.8'); // цифирку можете свою поставить CorelDraw.FileNew; // или CorelDraw.FileOpen(FileName); CorelDraw.SetDocVisible(True); // можно и не показывать, что он там делает, но ведь интересно! :) // кстати, можно нарисовать, а потом показать - будет на 30% быстрее ... // ну и в конце CorelDraw.FileSave('NewName', 0, False, 0, False); CorelDraw.FileExit(False); // можно не писать, если не надо закрывать CorelDraw := Unassigned;
Формат функций доступным английским языком описан в draw_scr.hlp. Ну а дальше, чего душа (или начальство :) ) желает:
CorelDraw.SetPageOrientation(0); CorelDraw.SetPageSize(PageW, PageH); CorelDraw.NewLayer('NewLayer1'); CorelDraw.SelectLayer('NewLayer1'); CorelDraw.CreateEllipse(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), 0, 0, 0); // ничего я не перепутал!!! именно так у них координаты! CorelDraw.CreateRectangle(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), CalcX(Radius)); ...
А это Unit1.dfm
object Form1: TForm1 Left = 175 Top = 107 Width = 596 Height = 375 Caption = 'Form1' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 448 Top = 56 Width = 6 Height = 13 Caption = '[]' end object Label2: TLabel Left = 19 Top = 12 Width = 13 Height = 13 Caption = 'X=' end object Edit1: TEdit Left = 16 Top = 32 Width = 417 Height = 21 TabOrder = 0 Text = '((24/2)+3*(7-x))' OnChange = Edit1Change end object BitBtn1: TBitBtn Left = 448 Top = 32 Width = 75 Height = 22 TabOrder = 1 OnClick = BitBtn1Click Kind = bkOK end object Memo1: TMemo Left = 16 Top = 80 Width = 241 Height = 249 TabOrder = 2 end object Button1: TButton Left = 448 Top = 2 Width = 75 Height = 25 Caption = 'prepare' TabOrder = 3 OnClick = Button1Click end object Edit2: TEdit Left = 36 Top = 8 Width = 53 Height = 21 TabOrder = 4 Text = '2' end object Button2: TButton Left = 264 Top = 80 Width = 75 Height = 25 Caption = 'Speed test' TabOrder = 5 OnClick = Button2Click end endАлгоритм проверки контрольного числа ИНН и страхового номера ПФ
Модуль содержит две функции для проверки контрольного числа ИНН и страхового номера ПФ CheckINN - Функция вычисляет контрольное число ИНН и возвращает True если ИНН введен правильно или False в противном случае
В качестве параметра передается проверяемый ИНН
Для справки: структура ИНН
В качестве параметра передается страховой номер ПФ без разделителей
Проверка контрольного числа Страхового номера проводится только для номеров больше номера 001-001-998.
Контрольное число Страхового номера рассчитывается следующим образом: каждая цифра Страхового номера умножается на номер своей позиции (позиции отсчитываются с конца), полученные произведения суммируются, сумма делится на 101, последние две цифры остатка от деления являются Контрольным числом.
Скачать архив (1.2K)
Алгоритм расчета контрольного числа ОГРН (основной государственный регистрационный номер)
Государственный регистрационный номер записи, вносимой в Единый государственный реестр юридических лиц (далее - государственный реестр), состоит из 13 цифр, расположенных в следующей последовательности: СГГККХХХХХХХЧ, где
| unit OGRN; interface function CheckOGRN(const OGRN: string): Boolean; implementation uses Sysutils; function CheckOGRN(const OGRN: string): Boolean; var VerifNumb: Int64; CheckNumb, ResultNumb: Byte; begin Result := Length(OGRN) = 13; if Not Result then Exit; VerifNumb := StrToInt64(Copy(OGRN, 1, 12)); CheckNumb := StrToInt(OGRN[13]); ResultNumb := VerifNumb mod 11; if ResultNumb > 9 then ResultNumb := ResultNumb - Round(ResultNumb/10)*10; Result := ResultNumb = CheckNumb; end; end. |
Автоматическое определение занятости приложения
| Раздел Сокровищница |
Компонент:TBusyDetector V0.1b Описание: Компонент для автоматического определения занятости приложения с целью развлечь пользователя при выполнении тяжелых операций, приводящих к зависанию GUI (пользовательского интерфейса). Интерфейс: property Enabled: Boolean; вкл/выкл слежения property Interval: Cardinal; интервал (в мсек) проверки занятости property Caption: TCaption; заголовок окна property Text: TCaption; текст окна property Stated: Boolean; вкл/выкл строки состояние property State: TCaption; текст сотсояние property Progressed: Boolean; вкл/выкл полосу прогресса property Min: Integer; property Max: Integer; property Position: Integer; позиция в полосе прогресса property Step: Integer; property OnGetWindowClass: TBusyWindowClassEvent; получение класса окна property OnBusyDetect: TNotifyEvent; событие на обнаружения занятости property OnIdleDetect: TNotifyEvent; конец занятости Показания: Delphi 3 и выше;
OS Win9X/WinNTX;
Руки2X;
Халява.
Комментарий:Очень часто, особенно в связи с одно-потоковой архитектурой приложения в Delphi, требуется вставлять хоть какие то предупреждения для пользователя перед и в процессе выполнения тяжелых операций таких как подключения к базе, массовые математические вычисления и т.п. но так как на это нет времени да и не во все влезешь я взялся в своем проекте решить эту проблему "глобально". Компонент сырой, требует серьезной доработки (например, если компилить в режиме рантайм пакетов - то ресурсы с анимацией недоступны), так что жду критики, пожеланий и конкретных предложений по email. Скачать компонент: (15.7K)
Митронов Станислав
Автоматизация создание BackUp-ов проектов
| Раздел Сокровищница |
Пробовал я много разного рода BackUp креаторов, и вот к чему я пришел: WinRAR + .BAT(CMD) - лучше нет (даже при разработке в команде)
пример использования:
Файл BackUp.CMD
| @echo Off echo --------------------------- echo RNZ prj. BackUp batch echo --------------------------- @echo On set tmpName=MyProject_src set backupDir=_BackUp\D6\Prj\MyProject start /w winrar a -r -y -ag_YYMMDD_HHMM -x.\Data\*.* -x@.\xlist.lst "%temp%\%tmpName%" %1 mkdir "..\_sources" mkdir C:\"%backupDir%" mkdir D:\"%backupDir%" mkdir E:\"%backupDir%" mkdir \\"MyNetDir\%backupDir%" copy /y "%temp%\%tmpName%*.rar" "..\_sources" copy /y "%temp%\%tmpName%*.rar" C:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" D:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" E:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" \\"MyNetDir\%backupDir%" del "%temp%\%tmpName%*.rar" rem start "..\_sources" rem start C:\"%backupDir%" rem start D:\"%backupDir%" rem start E:\"%backupDir%" rem start \\"MyNetDir\%backupDir%" set tmpName= set backupDir= |
BackUp.CMD и xlist.lst копируем в директорию(каталог, папку) с проектом, xlist.lst содержит список исключений и может иметь примерно следующий вид:
Файл xlist.lst
| ~*.* *.~* *.rar *.bak *.dcu *.res *.exe _qsq*.* |
Bat-файл в Группе проектов
| Раздел Сокровищница | амм на Delphi и объединении их в одну группу, в ту же группу можно добавить любой bat файл. Он будет выполнятся при каждой компиляции группы. Это можно использовать для выполнения какого-либо действий, необходимого для корректной компиляции или для выполнения действий сразу после перекомпиляции. Например, я это использую для подсчета "сборок" (build), т.е. компиляций. Как это сделать: File -> New -> Batch file Редактировать содержимое в Project -> Options (Shift+Ctrl+F11) Дальше - у кого какая фантазия... |
Bdetry
 | источник информации: |
| Использование EDBEngineError Exceptions Перевод с английского |
Перевод и адаптация - Елена Филиппова
Информация, которая описывает ошибки, возникающие при работе BDE, может быть получена приложением с помощью обработки исключения EDBENGINEERROR конструкцией try..except.
Когда возникает исключение EDBENGINEERROR, создается объект EDBEngineError и различные поля в этом объекте используются, чтобы программно определить какая именно некорректная ситуация произошла. Также, для данного исключения, может быть сгенерировано больше чем одно сообщение об ошибке. Таким образом необходимо выполнения итераций, чтобы получить всю необходимую информацию. Поля объекта, которые наиболее интересны в этом контексте: ErrorCount: type Integer; Определяет количество ошибок, которые содержит свойство Errors, отсчет начинается с нуля. Errors: type TDBError; Структура типа Record, которая содержит информацию о каждой сгенерированной специфической ошибке. Обращаться к каждой записи через нумерованный индекс. Errors.ErrorCode: type DBIResult; Определяет код ошибки, которая содержится в текущей записи. Errors.Category: type Byte; Категория ошибки. Errors.SubCode: type Byte; Дополнительный код для значения ErrorCode. Errors.NativeError: type LongInt; Код удаленной ошибки, возвращается сервером. Из он равен нулю, ошибка произошла не на сервере; в этом поле появляется код возврата SQL-выражения. Errors.Message: type TMessageStr; Если произошла ошибка на сервере, то это строка-сообщение сервера об ошибке в текущей записи Errors, если нет, то сообщение BDE. Объект EDBEngineError создается непосредственно в конструкции try..except в секции except. Однажды созданный, объект может передаваться другим процедурам для обработки ошибок.
Пример использования конструкции try..except для обработки исключения DBEngineError: procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin if Edit1.Text > ' ' then begin Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text); try Table1.Post; except on E: EDBEngineError do ShowError(E); end; end; end; В данной процедуре происходит попытка записать значение в поле таблице и при возникновении ошибки BDE, обработка ее перехватывается. Объект типа EDBEngineError передается как параметр процедуре ShowError. Обратите внимание, что в данном примере обрабатывается только ошибка BDE, что на самом деле недостаточно. В реальных условиях необходимо проверять все типы исключительных ситуаций.
Процедура ShowError, в свою очередь, отображает весь список сообщений, которые содержатся в переданной ей переменной: procedure TForm1.ShowError(AExc: EDBEngineError); var i: Integer; begin Memo1.Lines.Clear; Memo1.Lines.Add('Number of errors: ' + IntToStr(AExc.ErrorCount)); Memo1.Lines.Add(''); {Iterate through the Errors records} for i := 0 to AExc.ErrorCount - 1 do begin Memo1.Lines.Add('Message: ' + AExc.Errors[i].Message); Memo1.Lines.Add(' Category: ' + IntToStr(AExc.Errors[i].Category)); Memo1.Lines.Add(' Error Code: ' + IntToStr(AExc.Errors[i].ErrorCode)); Memo1.Lines.Add(' SubCode: ' + IntToStr(AExc.Errors[i].SubCode)); Memo1.Lines.Add(' Native Error: ' + IntToStr(AExc.Errors[i].NativeError)); Memo1.Lines.Add(''); end; end;
Библиотека для работы с LAN.
| Раздел Сокровищница | Alex, 09 апреля 2001г. |
unit NetProcs; interface uses Classes, Windows; type TAdapterStatus = record adapter_address: array [0..5] of Char; filler: array [1..4*SizeOf(Char)+19*SizeOf(Word) +3*SizeOf(DWORD)] of Byte; end; THostInfo = record username: PWideChar; logon_domain: PWideChar; oth_domains: PWideChar; logon_server: PWideChar; end;{record} function IsNetConnect : Boolean; {Возвращает TRUE если компьютер подключен к сети, иначе - FALSE} function AdapterToString(Adapter: TAdapterStatus): string; {Преобразует MAC адес в привычный xx-xx-xx-xx} function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; {Заполняет Addresses MAC-адресами компьютера с сетевым именем Machine. Возвращает число МАС адресов на компьютере} function GetNetUser(HostName: WideString): THostInfo; {Возвращает LOGIN текущего пользователя на HOSTNAME компьютере} implementation uses NB30, SysUtils; function IsNetConnect : Boolean; begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then Result:= True else Result:= False; end;{function} function AdapterToString(Adapter: TAdapterStatus): string; begin with Adapter do Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [ Integer(adapter_address[0]), Integer(adapter_address[1]), Integer(adapter_address[2]), Integer(adapter_address[3]), Integer(adapter_address[4]), Integer(adapter_address[5])]); end;{function} function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; const NCBNAMSZ = 16; // absolute length of a net name MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive NRC_GOODRET = $00; // good return NCBASTAT = $33; // NCB ADAPTER STATUS NCBRESET = $32; // NCB RESET NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS type PNCB = ^TNCB; TNCBPostProc = procedure (P: PNCB); stdcall; TNCB = record ncb_command: Byte; ncb_retcode: Byte; ncb_lsn: Byte; ncb_num: Byte; ncb_buffer: PChar; ncb_length: Word; ncb_callname: array [0..NCBNAMSZ - 1] of Char; ncb_name: array [0..NCBNAMSZ - 1] of Char; ncb_rto: Byte; ncb_sto: Byte; ncb_post: TNCBPostProc; ncb_lana_num: Byte; ncb_cmd_cplt: Byte; ncb_reserve: array [0..9] of Char; ncb_event: THandle; end; PLanaEnum = ^TLanaEnum; TLanaEnum = record length: Byte; lana: array [0..MAX_LANA] of Byte; end; ASTAT = record adapt: TAdapterStatus; namebuf: array [0..29] of TNameBuffer; end; var NCB: TNCB; Enum: TLanaEnum; I: Integer; Adapter: ASTAT; MachineName: string; begin Result := -1; Addresses.Clear; MachineName := UpperCase(Machine); if MachineName = '' then MachineName := '*'; FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBENUM; NCB.ncb_buffer := Pointer(@Enum); NCB.ncb_length := SizeOf(Enum); if Word(NetBios(@NCB)) = NRC_GOODRET then begin Result := Enum.Length; for I := 0 to Ord(Enum.Length) - 1 do begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBRESET; NCB.ncb_lana_num := Enum.lana[I]; if Word(NetBios(@NCB)) = NRC_GOODRET then begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBASTAT; NCB.ncb_lana_num := Enum.lana[i]; StrLCopy(NCB.ncb_callname, PChar(MachineName),NCBNAMSZ); StrPCopy(@NCB.ncb_callname[Length(MachineName)], StringOfChar(' ', NCBNAMSZ - Length(MachineName))); NCB.ncb_buffer := PChar(@Adapter); NCB.ncb_length := SizeOf(Adapter); if Word(NetBios(@NCB)) = NRC_GOODRET then Addresses.Add(AdapterToString(Adapter.adapt)); end; end; end; end;{function} function NetWkstaUserEnum(servername: PWideChar; level : DWord; var bufptr: Pointer; prefmaxlen: DWord; var entriesread: PDWord; var totalentries: PDWord; var resumehandle: PDWord ): LongInt ; stdcall; external 'netapi32.dll' name 'NetWkstaUserEnum'; function GetNetUser(HostName: WideString): THostInfo; var Info: Pointer; ElTotal: PDWord; ElCount: PDWord; Resume: PDWord; Error: LongInt; begin Resume:=0; NetWkstaUserEnum(PWideChar(HostName),1, Info,0, ElCount,ElTotal,Resume); Error:=NetWkstaUserEnum(PWideChar(HostName),1,Info,256*Integer(ElTotal), ElCount,ElTotal,Resume); case Error of ERROR_ACCESS_DENIED: Result.UserName:= 'ERROR - ACCESS DENIED'; ERROR_MORE_DATA: Result.UserName:= 'ERROR - MORE DATA'; ERROR_INVALID_LEVEL: Result.UserName:= 'ERROR - INVALID LEVEL'; else if Info <> nil then Result:=THostInfo(info^) else begin Result.username:= '???'; Result.logon_domain:= '???'; Result.oth_domains:= '???'; Result.logon_server:= '???'; end;{if} end;{case} end; {function} end.
Библиотека, реализующая некоторые алгоритмы линейной алгебры
| в Александр Васильевич, дата публикации 30 октября 2003г. |
Основным ядром, значительной части вычислительных алгоритмов (решение систем линейных и нелинейных уравнений, оптимизация), является алгоритмы линейной алгебры. Вашему вниманию предлагается библиотека, реализующая некоторые алгоритмы линейной алгебры. Выбор алгоритмов был довольно субъективным, и отбор был нацелен на решение систем линейных уравнений.
Возможности библиотеки:
Архивные файлы:
Библиотеки пользовательских функций UDF для Interbase на Free Pascal.
| Раздел Сокровищница |
Всем известно, что возможности interbase можно расширить за счет написания пользовательских функций UDF. Но почему на Free Pascal?
Есть ряд веских причин.
library libosh; {$mode objfpc} {$PACKRECORDS C} const // Чтобы не было проблем с распознаванием кодировок на разных платформах rus_chars:pChar = #197#210#211#206#208#192#205#202#213#209 +#194#204#229#243#232#238#240#224#234#245#241#236 ; lat_chars:pChar = 'ETYOPAHKXCBMeyuopakxcm'; small_chars:pChar = #113#119#101#114#116#121#117#105#111#112#97#115#100#102#103 +#104#106#107#108#122#120#99#118#98#110#109#233#246#243#234 +#229#237#227#248#249#231#245#250#244#251#226#224#239#240#238 +#235#228#230#253#255#247#241#236#232#242#252#225#254#184 ; cap_chars:pChar = #81#87#69#82#84#89#85#73#79#80#65#83#68#70#71#72#74#75#76#90 +#88#67#86#66#78#77#201#214#211#202#197#205#195#216#217#199 +#213#218#212#219#194#192#207#208#206#203#196#198#221#223#215 +#209#204#200#210#220#193#222#168 ; cp1251:pChar = #233#246#243#234#229#237#227#248#249#231#245#250#244#251#226 +#224#239#240#238#235#228#230#253#255#247#241#236#232#242#252 +#225#254#184#201#214#211#202#197#205#195#216#217#199#213#218 +#212#219#194#192#207#208#206#203#196#198#221#223#215#209#204 +#200#210#220#193#222#168 ; cp866:pChar = #169#230#227#170#165#173#163#232#233#167#229#234#228#235#162 +#160#175#224#174#171#164#166#237#239#231#225#172#168#226#236 +#161#238#241#137#150#147#138#133#141#131#152#153#135#149#154 +#148#155#130#128#143#144#142#139#132#134#157#159#151#145#140 +#136#146#156#129#158#240 ; koi8:pChar = #202#195#213#203#197#206#199#219#221#218#200#223#198#217#215#193 +#208#210#207#204#196#214#220#209#222#211#205#201#212#216#194#192 +#163 +#234#227#245#235#229#238#231#251#253#250#232#255#230#249#247#225 +#240#242#239#236#228#246#252#241#254#243#237#233#244#248#226#224 +#179 ; function replace_it(CString: PChar;scr: PChar;dest: PChar):PChar; var i,j:integer; begin i:=0; while (CString[i]<>#0) do begin j:=0; while (scr[j]<>#0) do begin if CString[i]=scr[j] then begin CString[i]:=dest[j]; Break; end; inc(j); end; inc(i); end; result:=CString; end; function latrus(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,lat_chars,rus_chars); end; function rupper(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,small_chars,cap_chars); end; function rlower(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cap_chars,small_chars); end; function dos2win(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp866,cp1251); end; function win2dos(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp1251,cp866); end; function koi82win(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,koi8,cp1251); end; function koi82dos(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,koi8,cp866); end; function dos2koi8(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp866,koi8); end; function win2koi8(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp1251,koi8); end; function UDF_strcat(dest,source : pchar) : pchar; stdcall;export; begin result:=strcat(dest,source); end; exports latrus name 'latrus', // преобразование латинских бук, похожих на кирилличесике // в кириллические 1251. Иногда надо при переделке существующих // баз данных, в которых некоторые русские буквы по ошибке // набраны латинницей rupper name 'rupper', // перевод русских в верхний и нижний регистры rlower name 'rlower', dos2win name 'dos2win', // перевод различных кодировок кириллицы win2dos name 'win2dos', koi82win name 'koi82win', koi82dos name 'koi82dos', dos2koi8 name 'dos2koi8', win2koi8 name 'win2koi8' ; end.
Откомпилированные библиотеки должны иметь названия libosh.dll для win32 и libosh.so для FreeBSD и Linux.
Для подключения этих функций используйте скрипт CONNECT 'mysvr:/db/test.gdb' USER 'UZVER' PASSWORD 'uzver'; DECLARE EXTERNAL FUNCTION LATRUS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'latrus' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION RUPPER CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'rupper' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION RLOWER CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'rlower' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION DOS2WIN CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'dos2win' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION WIN2DOS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'win2dos' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION KOI82WIN CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'koi82win' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION KOI82DOS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'koi82dos' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION DOS2KOI8 CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'dos2koi8' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION WIN2KOI8 CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'win2koi8' MODULE_NAME 'libosh'; commit; В порте freepascal для freeBSD немного недоделан модуль sysutils, и вызов некоторых функций из него приводит к runtime error. Пример использования функций библиотеки SELECT WIN2KOI8(NAME) FROM PEOPLE и т.д.
Найти freepascal можно по адресу
Кубанычбек Тажмамат уулу,
03 мая 2001г
Специально для
Быстрая обработка спрайтов без применения DirectX
Каждый, кто пытался интенсивно работать со спрайтами при помощи WinAPI, или, что то же самое, методами TCanvas, убеждался в их чрезвычайно низкой производительности. Такова цена универсальности, ничего с этим не поделаешь. Кроме того, средства WinAPI не покрывают все типовые задачи, которые возникают при работе со спрайтовой графикой.
Многие ют переход к аппаратному ускорению — DirectX и OpenGL. Но для повседневных задач желательно не отрываться от привычных средств, к тому же самую главную функцию — вывод на экран — WinAPI выполняет вполне удовлетворительно.
По-моему, лучшим выходом может стать использование обычных, хранимых в памяти изображений (TBitmap), создание и вывод их при помощи обычных средств при замене промежуточного звена, а именно процедур обработки спрайтов. За счет применения низкоуровнего кода, жесткой привязки изображений к определенному формату удается достичь вполне приемлемой производительности. Ускорение в 5-10-20 раз далеко не предел, особенно в процедурах, использующих MMX.
Для лучшей совместимости и с VCL, и с KOL я решил не инкапсулировать код в виде объекта, а оставить его в виде отдельных процедур с осмысленными названиями.
Модуль SpriteUtils решает 5 типовых задач:
Не все функции можно достичь одной операцией и не все подходят для всех форматов. Более всего приветствуется формат 24 бита на пиксел, поэтому в прикладных задачах, скорее всего, понадобится комбинировать несколько процедур последовательно.
Для тех, кто заботится о совместимости со старым "железом", есть процедуры, не использующие MMX (и оттого более медленные).
Несколько примеров: Сложение спрайтов с заданной прозрачностью. Цвет источника умножается на прозрачность (0.0 — 1.0), цвет приемника на дополнение до 1, результат складывается
Наложение спрайта с одним маскированным цветом Копируются все пикселы источника кроме тех, которые равны выбранному прозрачному цвету
Наложение маски из спрайта Копируются только те пикселы источника, которые равны выбранному цвету
В архиве прилагаются:
Михаил Рудаков,
Freeware, 2003.
Цели использования
В некоторых областях часто встречается ситуация, когда требуется вычислять значения функций, задаваемых непосредственно во время работы программы. Иногда для этого достаточно создания интерпретаторов, которые производят как анализ, так и вычисление выражения средствами языка высокого уровня.Однако в случаях, когда на первое место среди качеств программы выходит ее быстродействие, такой вариант становится неприемлемым. Как раз для приложений, производящих длительные вычисления, и был создан данный модуль, анализ формулы в котором производится так же, как и в интерпретаторах (благодаря однократности действия оно не оказывает влияния на скорость), но ее расчет при конкретных значениях переменных происходит с той же (либо большей) скоростью, что и при вызове обычных функций Delphi.
Что это и зачем или Немного наглой саморекламы
Эта программа представляет собой простенький компилятор синтаксических выражений. "Ну опять", - скажет невнимательный читатель, но мы то с тобой внимательные, и понимаем что компилятор, это совсем не то что валяется на каждом программистском сайте. В отличие от парсера (или интерпретатора) такую штуку встретить можно несколько реже. Если честно, то когда она мне была нужна, я ее нигде не встретил. И поэтому родилась эта программа.Что он может или Какие мы маленькие
Да в общем-то немного, и ценности в ней мало :). Она может вычислять выражения (тип - вещественное число с плавающей точкой (на момент написания это называлось Real)) с использованием операций (+,-,/,*). Мало... А разве сложно дописать пару строк чтобы обработать Y или экспоненту коли они будут нужны?Д о п о л н е н и е
| Раздел Сокровищница | , дата публикации 04 апреля 2001г. |
В наше время крупных проектов на Васике и Яве, фантастического снижения цен на мегагерцы и мегабайты, скриптуемых языков, COM и супер технологии NET на вагончике сидюков, писать критичные по времени процедуры на ассемблере не модно, можно получить жалостливую усмешку. Все многозначительно обсуждают что <вот у си оптимизация>, а ассемблер это так не переносимо - вдруг Intel загнется ;-).
Где-то два года назад, я разрабатывал программу сервер для интенсивной круглосуточной работы, в том числе работы по забору и переформатированию почты. Одним из этапов форматирования являлось преобразования из koi8,iso,dos,mac в любимый win1251.
Поскольку это часто выполняемая для больших объемов данных операция, то был смысл её оптимизировать. Сразу отбрасывались вложенные циклы, кучи условий вида if (Ch>X) and (Ch
Специально для
DCOM permissions
| Раздел Сокровищница |
Технология DCOM основана на технологии COM и представляет собой ее продолжение. Основное назначение DCOM - организация взаимодействия клиента с удаленным сервером.
Как пользоваться DCOM
Чтобы воспользоваться возможностями DCOM должны быть соблюдены следующие требования:
Скачать исходные коды: (28 K)
| | "Knowledge itself is power" F.Bacon |
| Разное |
Раздел Сокровищница
(17.01.00)
(21.01.00)
(31.01.00)
(31.01.00)
(01.09.00)
Вариант №5 (01.09.00) Автор: Павленко Алексей
Я же делал несколько по-другому, вернее больше: Взял стандартные таблицы из FARа. Достаточно иметь iso2dos.tbl (двоичные файлы длиной 256 байт, сейчас их буду прилинковывать к exe, как это сделать, посоветуете?)
koi2dos.tbl
mac2dos.tbl
win2dos.tbl
При запуске программы читаю таблицы и запоминаю в массивах type ChTable=array [0..255] of byte; var iso2dos, koi2dos, mac2dos, win2dos: ChTable; После этого легко переводить из одной кодировки в другую. Для этого надо заполнить массив t: ChTable; Есть несколько вариантов: 1) Переводим в ДОС case fm.cbCharsetIn.ItemIndex of 1: t:=win2dos; 2: t:=koi2dos; 3: t:=iso2dos; 4: t:=mac2dos; end; 2) Переводим из ДОС case fm.cbCharsetOut.ItemIndex of 1: t2:=win2dos; 2: t2:=koi2dos; 3: t2:=iso2dos; 4: t2:=mac2dos; end; for i:=128 to 255 do t[t2[i]]:=i; for i:=0 to 127 do t[i]:=i; 3) Не ДОС-кодировки // из входной кодировки в ДОС case fm.cbCharsetIn.ItemIndex of 1: t1:=win2dos; 2: t1:=koi2dos; 3: t1:=iso2dos; 4: t1:=mac2dos; end; // таблица для ДОС->выходная case fm.cbCharsetOut.ItemIndex of 1: t2:=win2dos; 2: t2:=koi2dos; 3: t2:=iso2dos; 4: t2:=mac2dos; end; for i:=128 to 255 do t3[t2[i]]:=i; for i:=0 to 127 do t3[i]:=i; // теперь уже окончательная таблица для входной кодировки в выходную for i:=0 to 255 do t[i]:=t3[t1[i]]; Ну а сам перевод делается уже легко: while not eof(f) do begin readln(f, s); s2:=''; for i:=1 to Length(s) do s2:=s2+chr(t[byte(s[i])]); writeln(fout, s2); end; Вроде еще быстрее сделать невозможно. Но это только теоретически ;)
Готовую программу можно скачать с
Вариант №4 (31.01.00) Автор: Еремеев Алексей
const Koi = 'юабцдефгхийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ'; Win = 'бвчздецъйклмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС'; SerH = 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ'; SerL = 'абвгдежзийклмнопрстуфхцчшщъыьэюя'; procedure ANSI2KOI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $B8 then Str[i] := char($A3) else if k = $A8 then Str[i] := char($B3) else if k > $BF then Str[i] := Win[k - $BF]; end; end; procedure KOI2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A3 then Str[i] := 'ё' else if k = $B3 then Str[i] := 'Ё' else if k > $BF then Str[i] := Koi[k - $BF]; end; end; procedure ANSI2IBM(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $B8 then Str[i] := char($F1) else if k = $A8 then Str[i] := char($F0) else if k > $EF then Str[i] := char(k - 16) else if (k > $BF) and (k < $F0) then Str[i] := char(k - 64); end; end; procedure IBM2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $F0 then Str[i] := 'Ё' else if k = $F1 then Str[i] := 'ё' else if (k > $7F) and (k < $A0) then Str[i] := SerH[k - $7F] else if (k > $9F) and (k < $B0) then Str[i] := SerL[k - $9F] else if (k > $DF) and (k < $F0) then Str[i] := SerL[k - $CF]; end; end; procedure ANSI2Mac(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A8 then Str[i] := char($DD) else if k = $B8 then Str[i] := char($DE) else if k = $FF then Str[i] := char($DF) else if (k > $BF) and (k < $E0) then Str[i] := char(k - 64); end; end; procedure Mac2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $DD then Str[i] := 'Ё' else if k = $DE then Str[i] := 'ё' else if k = $DF then Str[i] := 'я' else if (k > $7F) and (k < $A0) then Str[i] := SerH[k - $7F] else if (k > $DF) and (k < $FF) then Str[i] := SerL[k - $DF]; end; end; procedure ANSI2ISO(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A8 then Str[i] := char($A1) else if k = $B8 then Str[i] := char($F1) else if k > $BF then Str[i] := char(k - 16); end; end; procedure ISO2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A1 then Str[i] := 'Ё' else if k = $F1 then Str[i] := 'ё' else if k < $F0 then begin if k > $CF then Str[i] := SerL[k - $CF] else if k > $AF then Str[i] := SerH[k - $AF]; end; end; end;
Вариант №3 (31.01.00) Автор: Constantin G. Nekhoroshkov
Предлагаю всеобщему вниманию вот такой вот unit. Он решает проблемы конвертации не только Win1251->KOI8 но и конвертации в другие кодировки. //---Begin of Unit RusChar Unit RusChar; interface Function ALT2ISO(Ch1: byte): byte; Function ALT2KOI(Ch1: byte): byte; Function ALT2MAC(Ch1: byte): byte; Function ALT2WIN(Ch1: byte): byte; Function ISO2ALT(Ch1: byte): byte; Function ISO2KOI(Ch1: byte): byte; Function ISO2MAC(Ch1: byte): byte; Function ISO2WIN(Ch1: byte): byte; Function KOI2ALT(Ch1: byte): byte; Function KOI2ISO(Ch1: byte): byte; Function KOI2MAC(Ch1: byte): byte; Function KOI2WIN(Ch1: byte): byte; Function MAC2ALT(Ch1: byte): byte; Function MAC2ISO(Ch1: byte): byte; Function MAC2KOI(Ch1: byte): byte; Function MAC2WIN(Ch1: byte): byte; Function WIN2ALT(Ch1: byte): byte; Function WIN2ISO(Ch1: byte): byte; Function WIN2KOI(Ch1: byte): byte; Function WIN2MAC(Ch1: byte): byte; Function ConvertString(InputString: string; Convert_Flag: byte): string; implementation Const //Alt decode contants ALT_2_ISO=1; ALT_2_KOI=2; ALT_2_MAC=3; ALT_2_WIN=4; //Iso decode contants ISO_2_ALT=5; ISO_2_KOI=6; ISO_2_MAC=7; ISO_2_WIN=8; //Koi decode contants KOI_2_ALT=9; KOI_2_ISO=10; KOI_2_MAC=11; KOI_2_WIN=12; //Mac decode contants MAC_2_ALT=13; MAC_2_ISO=14; MAC_2_KOI=15; MAC_2_WIN=16; //Win decode contants WIN_2_ALT=17; WIN_2_ISO=18; WIN_2_KOI=19; WIN_2_MAC=20; ALTTable: array [1..64] of byte =( 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239 ); ISOTable: array [1..64] of byte =( 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239 ); KOITable: array [1..64] of byte =( 225, 226, 247, 231, 228, 229, 246, 250, 233, 234, 235, 236, 237, 238, 239, 240, 242, 243, 244, 245, 230, 232, 227, 254, 251, 253, 255, 249, 248, 252, 224, 241, 193, 194, 215, 199, 196, 197, 214, 218, 201, 202, 203, 204, 205, 206, 207, 208, 210, 211, 212, 213, 198, 200, 195, 222, 219, 221, 223, 217, 216, 220, 192, 209 ); MACTable: array [1..64] of byte =( 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 223 ); WINTable: array [1..64] of byte =( 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 ); Function ALT2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2ISO:=ISOtable[i]; exit; end; end; ALT2ISO:=ch1; end; Function ALT2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2KOI:=KOItable[i]; exit; end; end; ALT2KOI:=ch1; end; Function ALT2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2MAC:=MACtable[i]; exit; end; end; ALT2MAC:=ch1; end; Function ALT2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2WIN:=WINtable[i]; exit; end; end; ALT2WIN:=ch1; end; Function ISO2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2ALT:=ALTtable[i]; exit; end; end; ISO2ALT:=ch1; end; Function ISO2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2KOI:=KOItable[i]; exit; end; end; ISO2KOI:=ch1; end; Function ISO2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2MAC:=MACtable[i]; exit; end; end; ISO2MAC:=ch1; end; Function ISO2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2WIN:=WINtable[i]; exit; end; end; ISO2WIN:=ch1; end; Function KOI2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2ALT:=ALTtable[i]; exit; end; end; KOI2ALT:=ch1; end; Function KOI2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2ISO:=ISOtable[i]; exit; end; end; KOI2ISO:=ch1; end; Function KOI2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2MAC:=MACtable[i]; exit; end; end; KOI2MAC:=ch1; end; Function KOI2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2WIN:=WINtable[i]; exit; end; end; KOI2WIN:=ch1; end; Function MAC2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2ALT:=ALTtable[i]; exit; end; end; MAC2ALT:=ch1; end; Function MAC2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2ISO:=ISOtable[i]; exit; end; end; MAC2ISO:=ch1; end; Function MAC2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2KOI:=KOItable[i]; exit; end; end; MAC2KOI:=ch1; end; Function MAC2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2WIN:=WINtable[i]; exit; end; end; MAC2WIN:=ch1; end; Function WIN2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2ALT:=ALTtable[i]; exit; end; end; WIN2ALT:=ch1; end; Function WIN2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2ISO:=ISOtable[i]; exit; end; end; WIN2ISO:=ch1; end; Function WIN2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2KOI:=KOItable[i]; exit; end; end; WIN2KOI:=ch1; end; Function WIN2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2MAC:=MACtable[i]; exit; end; end; WIN2MAC:=ch1; end; Function ConvertString(InputString: string; Convert_Flag: byte): string; Var i: word; ConvertByte: byte; begin ConvertString:=''; If InputString='' then exit; for i:=1 to length(InputString) do begin ConvertByte:=ord(InputString[i]); Case Convert_Flag of ALT_2_ISO: ConvertByte:=Alt2Iso(ConvertByte); ALT_2_KOI: ConvertByte:=Alt2Koi(ConvertByte); ALT_2_MAC: ConvertByte:=Alt2Mac(ConvertByte); ALT_2_WIN: ConvertByte:=Alt2Win(ConvertByte); ISO_2_ALT: ConvertByte:=Iso2Alt(ConvertByte); ISO_2_KOI: ConvertByte:=Iso2Koi(ConvertByte); ISO_2_MAC: ConvertByte:=Iso2Mac(ConvertByte); ISO_2_WIN: ConvertByte:=Iso2Win(ConvertByte); KOI_2_ALT: ConvertByte:=Koi2Alt(ConvertByte); KOI_2_ISO: ConvertByte:=Koi2Iso(ConvertByte); KOI_2_MAC: ConvertByte:=Koi2Mac(ConvertByte); KOI_2_WIN: ConvertByte:=Koi2Win(ConvertByte); MAC_2_ALT: ConvertByte:=Mac2Alt(ConvertByte); MAC_2_ISO: ConvertByte:=Mac2Iso(ConvertByte); MAC_2_KOI: ConvertByte:=Mac2Koi(ConvertByte); MAC_2_WIN: ConvertByte:=Mac2Win(ConvertByte); WIN_2_ALT: ConvertByte:=Win2Alt(ConvertByte); WIN_2_ISO: ConvertByte:=Win2Iso(ConvertByte); WIN_2_KOI: ConvertByte:=Win2Koi(ConvertByte); WIN_2_MAC: ConvertByte:=Win2Mac(ConvertByte); end; InputString[i]:=chr(ConvertByte); end; ConvertString:=InputString; end; begin end. //---End of Unit RusChar
Вариант №2 (21.01.00) Автор: Алексей Вуколов
Этот вариант несколько более длинный (в плане размера таблиц перекодировки), но зато, как мне кажется, более универсальный (и, возможно, более быстрый). //--------------------------------------------------------------------------- type PCharRecodeTable = ^TCharRecodeTable; TCharRecodeTable = array[ #0..#255 ] of char; const WinToKOI8Table : TCharRecodeTable = (#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F, #$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F, #$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F, #$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F, #$40, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F, #$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$5B, #$5C, #$5D, #$5E, #$5F, #$60, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F, #$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$7B, #$7C, #$7D, #$7E, #$7F, #$80, #$81, #$82, #$83, #$84, #$85, #$86, #$87, #$88, #$89, #$8A, #$8B, #$8C, #$8D, #$8E, #$8F, #$90, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$9A, #$9B, #$9C, #$9D, #$9E, #$9F, #$A0, #$A1, #$A2, #$A3, #$A4, #$A5, #$A6, #$A7, #$A8, #$A9, #$AA, #$AB, #$AC, #$AD, #$AE, #$AF, #$B0, #$B1, #$B2, #$B3, #$B4, #$B5, #$B6, #$B7, #$B8, #$B9, #$BA, #$BB, #$BC, #$BD, #$BE, #$BF, #$E1, #$E2, #$F7, #$E7, #$E4, #$E5, #$F6, #$FA, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF, #$F0, #$F2, #$F3, #$F4, #$F5, #$E6, #$E8, #$E3, #$FE, #$FB, #$FD, #$FF, #$F9, #$F8, #$FC, #$E0, #$F1, #$C1, #$C2, #$D7, #$C7, #$C4, #$C5, #$D6, #$DA, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF, #$D0, #$D2, #$D3, #$D4, #$D5, #$C6, #$C8, #$C3, #$DE, #$DB, #$DD, #$DF, #$D9, #$D8, #$DC, #$C0, #$D1); KOI8ToWinTable : TCharRecodeTable = (#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F, #$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F, #$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F, #$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F, #$40, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F, #$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$5B, #$5C, #$5D, #$5E, #$5F, #$60, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F, #$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$7B, #$7C, #$7D, #$7E, #$7F, #$80, #$81, #$82, #$83, #$84, #$85, #$86, #$87, #$88, #$89, #$8A, #$8B, #$8C, #$8D, #$8E, #$8F, #$90, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$9A, #$9B, #$9C, #$9D, #$9E, #$9F, #$A0, #$A1, #$A2, #$A3, #$A4, #$A5, #$A6, #$A7, #$A8, #$A9, #$AA, #$AB, #$AC, #$AD, #$AE, #$AF, #$B0, #$B1, #$B2, #$B3, #$B4, #$B5, #$B6, #$B7, #$B8, #$B9, #$BA, #$BB, #$BC, #$BD, #$BE, #$BF, #$FE, #$E0, #$E1, #$F6, #$E4, #$E5, #$F4, #$E3, #$F5, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF, #$FF, #$F0, #$F1, #$F2, #$F3, #$E6, #$E2, #$FC, #$FB, #$E7, #$F8, #$FD, #$F9, #$F7, #$FA, #$DE, #$C0, #$C1, #$D6, #$C4, #$C5, #$D4, #$C3, #$D5, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF, #$DF, #$D0, #$D1, #$D2, #$D3, #$C6, #$C2, #$DC, #$DB, #$C7, #$D8, #$DD, #$D9, #$D7, #$DA); //--------------------------------------------------------------------------- function RecodeChar( Ch : char; const Table : TCharRecodeTable ) : char; begin Result := Table[ Ch ]; end; //--------------------------------------------------------------------------- function CharWinToKOI8( Ch : char ) : char; begin Result := WinToKOI8Table[ Ch ]; end; //--------------------------------------------------------------------------- function CharKOI8ToWin( Ch : char ) : char; begin Result := KOI8ToWinTable[ Ch ]; end; //--------------------------------------------------------------------------- function RecodeStr( Source : string; const Table : TCharRecodeTable ) : string; var i : integer; begin Result := ''; for i := 1 to length( Source ) do Result := Result + Table[ Source[i] ]; end; //---------------------------------------------------------------------------
Вариант №1 (17.01.00) Автор: Дмитрий В. Полщанов const Koi: Array[0..66] of Char = ('Ј', 'Ё', 'ё', 'А', 'Б', 'В', 'Г', 'Д', 'Е', 'Ж', 'З', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Р', 'С', 'Т', 'У', 'Ф', 'Х', 'Ц', 'Ч', 'Ш', 'Щ', 'Ъ', 'Ы', 'Ь', 'Э', 'Ю', 'Я', 'а', 'б', 'в', 'г', 'д', 'е', 'ж', 'з', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п', 'р', 'с', 'т', 'у', 'ф', 'х', 'ц', 'ч', 'ш', 'щ', 'ъ', 'ы', 'ь', 'э', 'ю', 'я'); Win: Array[0..66] of Char = ('ё', 'Ё', 'Ј', 'ю', 'а', 'б', 'ц', 'д', 'е', 'ф', 'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п', 'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з', 'ш', 'э', 'щ', 'ч', 'ъ', 'Ю', 'А', 'Б', 'Ц', 'Д', 'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь', 'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ'); //--------------------------------------------------------------------------- function WinToKoi(Str: String): String; var i, j, Index: Integer; begin Result := ''; for i := 1 to Length(Str) do begin Index := -1; for j := Low(Win) to High(Win) do if Win[j] = Str[i] then begin Index := j; Break; end; if Index = -1 then Result := Result + Str[i] else Result := Result + Koi[Index]; end; end; //--------------------------------------------------------------------------- function KoiToWin(Str: String): String; var i, j, Index: Integer; begin Result := ''; for i := 1 to Length(Str) do begin Index := -1; for j := Low(Win) to High(Win) do if Koi[j] = Str[i] then begin Index := j; Break; end; if Index = -1 then Result := Result + Str[i] else Result := Result + Win[Index]; end; end; //--------------------------------------------------------------------------- procedure SendFileOnSMTP(Host: String; Port: Integer; Subject, FromAddress, ToAddress, Body, FileName: String); var NMSMTP: TNMSMTP; begin if DelSpace(ToAddress) = '' then Exit; if ToAddress[1] = ';' then Exit; if (DelSpace(FileName) <> '') and not FileExists(FileName) then raise Exception.Create('SendFileOnSMTP: file not exist: ' + FileName); NMSMTP := TNMSMTP.Create(nil); try NMSMTP.Host := Host; NMSMTP.Port := Port; NMSMTP.Charset := 'koi8-r'; NMSMTP.PostMessage.FromAddress := FromAddress; NMSMTP.PostMessage.ToAddress.Text := ToAddress; NMSMTP.PostMessage.Attachments.Text := FileName; NMSMTP.PostMessage.Subject := Subject; NMSMTP.PostMessage.Date := DateTimeToStr(Now); NMSMTP.UserID := 'netmaster'; NMSMTP.PostMessage.Body.Text := WinToKoi(Body); NMSMTP.FinalHeader.Clear; NMSMTP.TimeOut := 5000; NMSMTP.Connect; NMSMTP.SendMail; NMSMTP.Disconnect; finally NMSMTP.Free; end; end; //---------------------------------------------------------------------------
DelphiVCLFAQ
 | источник информации: |
| DELPHI VCL FAQ Перевод с английского |
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи.
Скачать (38 K) для просмотра в off-line.
Вернуться к разделу
Вопрос: Как разместить прозрачную надпись на TBitmap? Пример: 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; Вопрос: Можно ли обратиться к колонке или строке grid'а по заголовку? Ответ: В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).
Пример: procedure TForm1.FormCreate(Sender: TObject); begin StringGrid1.Rows[1].Strings[0] := 'This Row'; StringGrid1.Cols[1].Strings[0] := 'This Column'; end; function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer; var i : integer; begin for i := 0 to Grid.ColCount - 1 do if Grid.Rows[0].Strings[i] = ColName then begin Result := i; exit; end; Result := -1; end; function GetGridRowByName(Grid : TStringGrid; RowName : string): integer; var i : integer; begin for i := 0 to Grid.RowCount - 1 do if Grid.Cols[0].Strings[i] = RowName then begin Result := i; exit; end; Result := -1; end; procedure TForm1.Button1Click(Sender: TObject); var Column : integer; Row : integer; begin Column := GetGridColumnByName(StringGrid1, 'This Column'); if Column = -1 then ShowMessage('Column not found') else ShowMessage('Column found at ' + IntToStr(Column)); Row := GetGridRowByName(StringGrid1, 'This Row'); if Row = -1 then ShowMessage('Row not found') else ShowMessage('Row found at ' + IntToStr(Row)); end; Вопрос: Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.
Ответ: Можно перехватить сообщение CM_DIALOGCHAR. Пример: type TForm1 = class(TForm) PageControl1: TPageControl; TabSheet1: TTabSheet; TabSheet2: TTabSheet; TabSheet3: TTabSheet; private {Private declarations} procedure CMDialogChar(var Msg:TCMDialogChar); message CM_DIALOGCHAR; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.CMDialogChar(var Msg:TCMDialogChar); var i : integer; begin with PageControl1 do begin if Enabled then for i := 0 to PageControl1.PageCount - 1 do if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and (Pages[i].TabVisible)) then begin Msg.Result:=1; ActivePage := Pages[i]; exit; end; end; inherited; end; Вопрос: При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?
Ответ: Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.
Вопрос: Можно ли изменить число колонок и их ширину в компоненте TFileListBox? Ответ: В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.
Пример: with TDirectoryListBox(FileListBox1) do begin Columns := 2; SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0); end; Вопрос: Как настроить табуляцию в компоненте TMemo? Ответ: Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел.
Пример: procedure TForm1.FormCreate(Sender: TObject); var DialogUnitsX : LongInt; PixelsX : LongInt; i : integer; TabArray : array[0..4] of integer; begin Memo1.WantTabs := true; DialogUnitsX := LoWord(GetDialogBaseUnits); PixelsX := 20; for i := 1 to 5 do begin TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX; end; SendMessage(Memo1.Handle, EM_SETTABSTOPS,5,LongInt(@TabArray)); Memo1.Refresh; end; Вопрос: Как перехватить нажатия функциональных клавиш и стрелок? Ответ: Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы.
Пример: procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_RIGHT then Form1.Caption := 'Right'; if Key = VK_F1 then Form1.Caption := 'F1'; end; Вопрос: При обработке события DrawCell компонента DrawGrid я пишу Font.Color := clRed; и получаю бесконечный цикл мерцаний. Почему?
Ответ: Правильно укажите границы используемого канваса. Пример: If (Row = 0) then begin DrawGrid1.Canvas.Font.Color := clRed; DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col)); end; Вопрос: При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему? Ответ: Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.
Пример: var bm : TBitmap; OldBkMode : integer; begin bm := TBitmap.Create; bm.Width := BitBtn1.Glyph.Width; bm.Height := BitBtn1.Glyph.Height; bm.Canvas.Draw(0, 0, BitBtn1.Glyph); OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent); bm.Canvas.TextOut(0, 0, 'The Caption'); SetBkMode(bm.Canvas.Handle, OldBkMode); BitBtn1.Glyph.Assign(bm); end; Вопрос: Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента управления Windows? Ответ: Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.
Пример: unit caret1; interface {$IFDEF WIN32} uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ELSE} uses WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ENDIF} type TForm1 = class(TForm) Edit1: TEdit; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private {Private declarations} public {Public declarations} CaretBm : TBitmap; CaretBmBk : TBitmap; OldEditsWindowProc : Pointer; end; var Form1: TForm1; implementation {$R *.DFM} type {$IFDEF WIN32} WParameter = LongInt; {$ELSE} WParameter = Word; {$ENDIF} LParameter = LongInt; {New windows procedure for the edit control} function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin {Call the old edit controls windows procedure} NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL); if TheMessage = WM_SETFOCUS then begin CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); end; if TheMessage = WM_KILLFOCUS then begin HideCaret(WindowHandle); DestroyCaret; end; if TheMessage = WM_KEYDOWN then begin if ParamW = VK_BACK then CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); end; end; procedure TForm1.FormCreate(Sender: TObject); begin {Create a smiling bitmap using the wingdings font} CaretBm := TBitmap.Create; CaretBm.Canvas.Font.Name := 'WingDings'; CaretBm.Canvas.Font.Height := Edit1.Font.Height; CaretBm.Canvas.Font.Color := clWhite; CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2; CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2; CaretBm.Canvas.Brush.Color := clBlue; CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height)); CaretBm.Canvas.TextOut(1, 1, 'J'); {Create a frowming bitmap using the wingdings font} CaretBmBk := TBitmap.Create; CaretBmBk.Canvas.Font.Name := 'WingDings'; CaretBmBk.Canvas.Font.Height := Edit1.Font.Height; CaretBmBk.Canvas.Font.Color := clWhite; CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2; CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2; CaretBmBk.Canvas.Brush.Color := clBlue; CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height)); CaretBmBk.Canvas.TextOut(1, 1, 'L'); {Hook the edit controls window procedure} OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(@NewWindowProc))); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Unhook the edit controls window procedure and clean up} SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc)); CaretBm.Free; CaretBmBk.Free; end; Вопрос: При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?
Ответ: Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.
Пример: SysUtils.Abort; Вопрос: Почему при изменении цвета букв StatusBar'а ничего не происходит? Ответ: Status bar - стандартный элемент управления Windows, и соответственно цвет его букв - значение clBtnText которое изменяется с помощью настроек в Control Panel. Этот цвет черный по умолчанию и может изменяться в зависимости от выбранной цветовой схемы. Другие стандартные элемент управления Windows, например кнопки, также имеют цвет букв, настраиваемый из ControlPanel. StatusBar и его панели имеют свойство "owner-draw", позволяющее Вам использовать любой цвет букв.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1'); end; end; Вопрос: Как сделать многострочную надпись на TBitBtn? Ответ: Выводите текст надписи непосредственно на "glyph" TBitBtn'а. См. пример. Пример: procedure TForm1.FormCreate(Sender: TObject); var R : TRect; N : Integer; Buff : array[0..255] of Char; begin with BitBtn1 do begin Caption := 'A really really long caption'; Glyph.Canvas.Font := Self.Font; Glyph.Width := Width - 6; Glyph.Height := Height - 6; R := Bounds(0, 0, Glyph.Width, 0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R, DT_CENTER or DT_WORDBREAK or DT_CALCRECT); OffsetRect(R,(Glyph.Width - R.Right) div 2, (Glyph.Height - R.Bottom) div 2); DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R, DT_CENTER or DT_WORDBREAK); end; end; Вопрос: Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш? (например включить курсив по нажатию Ctrl + I)
Ответ: В примере стили шрифта меняются по нажатию след. комбинаций клавиш Ctrl + B - вкл/выкл жирного шрифта Ctrl + I - вкл/выкл наклонного шрифта Ctrl + S - вкл/выкл зачеркнутого шрифта Ctrl + U - вкл/выкл подчеркнутого шрифта Пример: const KEY_CTRL_B = 02; KEY_CTRL_I = 9; KEY_CTRL_S = 19; KEY_CTRL_U = 21; procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char); begin case Ord(Key) of KEY_CTRL_B: begin Key := #0; if fsBold in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsBold] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsBold]; end; KEY_CTRL_I: begin Key := #0; if fsItalic in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsItalic] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsItalic]; end; KEY_CTRL_S: begin Key := #0; if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout]; end; KEY_CTRL_U: begin Key := #0; if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsUnderline] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsUnderline]; end; end; end; Вопрос: В документации компонента TRegIniFile говорится, что можно изменять корневой ключ (root key). Я пытаюсь это сделать но ничего не получается.
Ответ: См. пример. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var WinIni : TRegIniFile; begin WinIni := TRegIniFile.Create(''); WinIni.RootKey := HKEY_LOCAL_MACHINE; WinIni.WriteString('Frank','Borland','Writes Fast Code!'); WinIni.Free; end; Вопрос: Можно ли динамически изменять свойство "owner" компонента во время выполнения программы? Ответ: Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent().
Вопрос: Как очистить содержимое Canvas'а? Ответ: Просто нарисуйте прямоугольник любого цвета. Пример: Canvas.Brush.Color := ClWhite; Canvas.FillRect(Canvas.ClipRect); Вопрос: Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
Ответ: Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы. begin Application.Initialize; if then begin Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); end else begin Application.CreateForm(TForm2, Form2); Application.CreateForm(TForm1, Form1); end; end. Application.Run; Вопрос: Как программно "щелкнуть" по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "handle".
Наверх к содержанию Вопрос: Можно ли отключить определенный элемент в RadioGroup? Ответ: В примере показано как получить доступ к отдельным элементам компонента TRadioGroup. Пример: procedure TForm1.Button1Click(Sender: TObject); begin TRadioButton(RadioGroup1.Controls[1]). Enabled := False; end; Вопрос: Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче? Ответ: Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам.
Вопрос: Как показать подсказки "hints" для элементов меню? Ответ: В примере создается обработчик события Application.Hint - подсказки меню изображаются на status panel. Пример: type TForm1 = class(TForm) Panel1: TPanel; MainMenu1: TMainMenu; MenuItemFile: TMenuItem; MenuItemOpen: TMenuItem; MenuItemClose: TMenuItem; OpenDialog1: TOpenDialog; procedure FormCreate(Sender: TObject); procedure MenuItemCloseClick(Sender: TObject); procedure MenuItemOpenClick(Sender: TObject); private {Private declarations} procedure HintHandler(Sender: TObject); public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Panel1.Align := alBottom; MenuItemFile.Hint := 'File Menu'; MenuItemOpen.Hint := 'Opens A File'; MenuItemClose.Hint := 'Closes the Application'; Application.OnHint := HintHandler; end; procedure TForm1.HintHandler(Sender: TObject); begin Panel1.Caption := Application.Hint; end; procedure TForm1.MenuItemCloseClick(Sender: TObject); begin Application.Terminate; end; procedure TForm1.MenuItemOpenClick(Sender: TObject); begin if OpenDialog1.Execute then Form1.Caption := OpenDialog1.FileName; end; Вопрос: Как опеделить состояние списка ComboBox, выпал/скрыт? Ответ: Пошлите ComboBox сообщение CB_GETDROPPEDSTATE. Пример: if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then begin {список ComboBox выпал} end; Вопрос: Как удалить каталог вместе со всеми содержащимися в нем файлами? Ответ: В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые другими программами в момент удаления - напишите дополнительную процедуру.
procedure TForm1.Button1Click(Sender: TObject); var DirInfo: TSearchRec; r: integer; begin r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo); while r = 0 do begin if ((DirInfo.Attr and FaDirectory <> FaDirectory) and (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); if RemoveDirectory('C:\Download\') = false then ShowMessage('Unable to delete directory: C:\Download\'); end; Вопрос: Как отключить системное меню формы и кнопки Minimize, Maximize, and Close во время выполнения(Runtime)?
Ответ: В приведенном примере показано как это сделать Пример: procedure TForm1.Button1Click(Sender: TObject); begin {Disable} Form1.BorderIcons := Form1.BorderIcons - [biSystemMenu, biMinimize, biMaximize]; end; procedure TForm1.Button2Click(Sender: TObject); begin {Enable} Form1.BorderIcons := Form1.BorderIcons + [biSystemMenu, biMinimize, biMaximize]; end; Вопрос: Как извлечь Red, Green, и Blue компонент из определенного цвета? Ответ: Используйте функции Window API Get RValue(), GetGValue(), и GetBValue(). Пример: procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Pen.Color := clRed; Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color))); end; Вопрос: Как определить номер текущей строки в TMemo? Ответ: Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR
Пример: procedure TForm1.Button1Click(Sender: TObject); var LineNumber : integer; begin LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0); ShowMessage(IntToStr(LineNumber)); end; Вопрос: Как проигрываеть MPEG файл в Delphi-программе? Ответ: Если в системе Windows MMSystem установлен декодер MPEG - используя компонент TMediaPlayer Пример: procedure TForm1.Button1Click(Sender: TObject); begin MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg'; MediaPlayer1.Open; MediaPlayer1.Display := Panel1; MediaPlayer1.DisplayRect := Panel1.ClientRect; MediaPlayer1.Play; end; Вопрос: Как использовать анимированный курсор? Ответ: Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример: procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; Вопрос: Как узнать о нажатии "non-menu" клавиши в момент когда меню показано? Ответ: Создайте обработчик сообщения WM_MENUCHAR. Пример: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus; type TForm1 = class(TForm) MainMenu1: TMainMenu; One1: TMenuItem; Two1: TMenuItem; THree1: TMenuItem; private {Private declarations} procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WmMenuChar(var m : TMessage); begin Form1.Caption := 'Non standard menu key pressed'; m.Result := 1; end; end. Вопрос: Как определить наличие сопроцессора? Ответ: В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
Пример: {$IFDEF WIN32} uses Registry; {$ENDIF} function HasCoProcesser : bool; {$IFDEF WIN32} var TheKey : hKey; {$ENDIF} begin Result := true; {$IFNDEF WIN32} if GetWinFlags and Wf_80x87 = 0 then Result := false; {$ELSE} if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0, KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false; RegCloseKey(TheKey); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin if HasCoProcesser then ShowMessage('Has CoProcessor') else ShowMessage('No CoProcessor - Windows Emulation Mode'); end; Вопрос: Как узнать серийный номер аудио CD? Ответ: CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример: uses MMSystem, MPlayer; procedure TForm1.Button1Click(Sender: TObject); var mp : TMediaPlayer; msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; ret : longint; begin mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := 'D:'; mp.Open; Application.ProcessMessages; FillChar(MediaString, sizeof(MediaString), #0); FillChar(msp, sizeof(msp), #0); msp.lpstrReturn := @MediaString; msp.dwRetSize := 255; ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp)); if Ret <> 0 then begin MciGetErrorString(ret, @MediaString, sizeof(MediaString)); Memo1.Lines.Add(StrPas(MediaString)); end else Memo1.Lines.Add(StrPas(MediaString)); mp.Close; Application.ProcessMessages; mp.free; end; end. Вопрос: Как вывести на элемент управления (Window control) текст, содержащий амперсанд - & ? Ответ: Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд как указание на то, что следующий символ - горячая клавиша (и поддчеркивает следующий символ вместо излбражения аперсанда).
Пример: Button1.Caption := 'Черное && Белое'; Вопрос: Как поместить bitmap в Metafile? Ответ: см. пример Пример: procedure TForm1.Button1Click(Sender: TObject); var m : TmetaFile; mc : TmetaFileCanvas; b : tbitmap; begin m := TMetaFile.Create; b := TBitmap.create; b.LoadFromFile('C:\SomePath\SomeBitmap.BMP'); m.Height := b.Height; m.Width := b.Width; mc := TMetafileCanvas.Create(m, 0); mc.Draw(0, 0, b); mc.Free; b.Free; m.SaveToFile('C:\SomePath\Test.emf'); m.Free; Image1.Picture.LoadFromFile('C:\SomePath\Test.emf'); end; Вопрос: Как узнать, что курсор мыши над моей формой? Ответ: Можно использовать функцию GetCapture() из Windows API. Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture. Пример: procedure TForm1.FormDeactivate(Sender: TObject); begin ReleaseCapture; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin If GetCapture = 0 then SetCapture(Form1.Handle); if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then Form1.Caption := 'Мышка над формой!' else Form1.Caption := 'Мышка вне формы...'; end; Вопрос: Как программно определить, что приложение работает под Windows NT? Ответ:см. пример Пример: function IsNT : bool; var osv : TOSVERSIONINFO; begin result := true; GetVersionEx(osv); if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit; result := false; end; procedure TForm1.Button1Click(Sender: TObject); begin if IsNt then ShowMessage('Running on NT') else ShowMessage('Not Running on NT'); end; Вопрос: Как создать bitmap из пиктогрммы (icon)? Ответ: Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е. Пример: procedure TForm1.Button1Click(Sender: TObject); var TheIcon : TIcon; TheBitmap : TBitmap; begin TheIcon := TIcon.Create; TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO'); TheBitmap := TBitmap.Create; TheBitmap.Height := TheIcon.Height; TheBitmap.Width := TheIcon.Width; TheBitmap.Canvas.Draw(0, 0, TheIcon); Form1.Canvas.Draw(10, 10, TheBitmap); TheBitmap.Free; TheIcon.Free; end; Вопрос: Как создать отдельную подсказку (hint) для каждой ячейки StringGrid? Ответ: В приведенном примере отслеживается движение курсора мыши - при перемещении между ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее номер текущей строки и колонки.
Пример: type TForm1 = class(TForm) StringGrid1: TStringGrid; procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormCreate(Sender: TObject); private {Private declarations} Col : integer; Row : integer; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin StringGrid1.Hint := '0 0'; StringGrid1.ShowHint := True; end; procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var r : integer; c : integer; begin StringGrid1.MouseToCell(X, Y, C, R); with StringGrid1 do begin if ((Row <> r) or(Col <> c)) then begin Row := r; Col := c; Application.CancelHint; StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c); end; end; end; Вопрос: Как внести изменения в код VCL? Ответ: Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.
-Но если Вы решили сделать это...
Изменеия в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:
Delphi 1 : Options | Environment | Library Delphi 2 : Tools | Options | Library Delphi 3 : Tools | Environment Options | Library Delphi 4 : Tools | Environment Options | Library C++ Builder : Options | Environment | Library Вопрос: Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic? Ответ: Функции TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же функциональность в Delphi. Пример: function TwipsPerPixelX(Canvas : TCanvas) : Extended; begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX); end; function TwipsPerPixelY(Canvas : TCanvas) : Extended; begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY); end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas))); ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas))); end; Вопрос: Как вставить содержимое файла в текущую позицию курсора в компонете TMemo? Ответ: Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;
var TheMStream : TMemoryStream; Zero : char; begin TheMStream := TMemoryStream.Create; TheMStream.LoadFromFile('C:\AUTOEXEC.BAT'); TheMStream.Seek(0, soFromEnd); //Null terminate the buffer! Zero := #0; TheMStream.Write(Zero, 1); TheMStream.Seek(0, soFromBeginning); Memo1.SetSelTextBuf(TheMStream.Memory); TheMStream.Free; end; Вопрос: Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
Ответ: См. пример. Пример: uses ClipBrd; procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if ((Key = ord('V')) and (ssCtrl in Shift)) then begin if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear; Memo1.SelText := 'Delphi is RAD!'; key := 0; end; end; Вопрос: Как создать эквивалент TEdit но только с выравниваением вводимого текста по центру или по правой стороне?
Ответ: TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример: procedure TForm1.FormCreate(Sender: TObject); begin Memo1.Alignment := taRightJustify; Memo1.MaxLength := 24; Memo1.WantReturns := false; Memo1.WordWrap := false; end; procedure MultiLineMemoToSingleLine(Memo : TMemo); var t : string; begin t := Memo.Text; if Pos(#13, t) > 0 then begin while Pos(#13, t) > 0 do delete(t, Pos(#13, t), 1); while Pos(#10, t) > 0 do delete(t, Pos(#10, t), 1); Memo.Text := t; end; end; procedure TForm1.Memo1Change(Sender: TObject); begin MultiLineMemoToSingleLine(Memo1); end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin MultiLineMemoToSingleLine(Memo1); end; Вопрос: Как запрограммировать undo? Ответ:См. пример Memo1.Perform(EM_UNDO, 0, 0); Если Вы хотите узнать, возможно ли выполнить операцию "Undo", проверьте "Undo status": If Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then begin {Undo is possible} end; Для выполнения "Redo" выполните "Undo" еще раз. Вопрос: Можно ли создать форму, которая получает дополнительные параметры в методе Сreate? Ответ: Просто замените конструктор Create класса Вашей формы. Пример: unit Unit2; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm2 = class(TForm) private {Private declarations} public constructor CreateWithCaption(aOwner: TComponent; aCaption: string); {Public declarations} end; var Form2: TForm2; implementation {$R *.DFM} constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string); begin Create(aOwner); Caption := aCaption; end; uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption'); Unit2.Form2.Show; end; Вопрос: Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется? Ответ: Status bar (строка состояния) - стандартный элемент управления Windows и цвет его шрифта задается через Control Panel (константа clBtnText). Этот цвет по умолчанию черный и может меняться при выборе пользователем той или иной цветовой схемы. У компонента ТStatusBar и его панелей есть возможность "owner-draw" - программной перерисовки, которая позволяет выводить на панель текст любого цвета. Измените свойство Style компонента TStatusBar.Panels на OwnerDraw.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1'); end; end; Вопрос: Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?
Ответ: В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
Пример: uses CommCtrl, ComCtrls; type TMyTrackBar = class(TTrackBar) procedure CreateParams(var Params: TCreateParams); override; end; procedure TMyTrackBar.CreateParams(var Params: TCreateParams); begin inherited; Params.Style := Params.Style and not TBS_ENABLESELRANGE; end; var MyTrackbar : TMyTrackbar; procedure TForm1.Button1Click(Sender: TObject); begin MyTrackBar := TMyTrackbar.Create(Form1); MyTrackbar.Parent := Form1; MyTrackbar.Left := 100; MyTrackbar.Top := 100; MyTrackbar.Width := 150; MyTrackbar.Height := 45; MyTrackBar.Visible := true; end; Вопрос: Мне нужен временный canvas, но когда я пытаюсь его создать получаю сообщения об ошибках. Как создать TCanvas?
Ответ: Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает Bitmap, рисует на его canvas'е, выводит этот canvas на форму и освобождает bitmap.
Пример: procedure TForm1.Button1Click(Sender: TObject); var bm : TBitmap; begin bm := TBitmap.Create; bm.Width := 100; bm.Height := 100; bm.Canvas.Brush.Color := clRed; bm.Canvas.FillRect(Rect(0, 0, 100, 100)); bm.Canvas.MoveTo(0, 0); bm.Canvas.LineTo(100, 100); Form1.Canvas.StretchDraw(Form1.ClientRect,Bm); bm.Free; end; Вопрос: В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?
Ответ: В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.
Пример: function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool; var Bm1 : TBitmap; Bm2 : TBitmap; begin Result := false; if Kind = bkCustom then exit; Bm1 := TBitmap.Create; case Kind of bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK'); bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL'); bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP'); bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES'); bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO'); bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE'); bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT'); bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY'); bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE'); bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL'); end; Bm2 := TBitmap.Create; Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; Bm2.Canvas.Brush.Color := ClBtnFace; Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), Bm1.canvas.pixels[0,0]); Bm1.Free; LockWindowUpdate(BitBtn.Parent.Handle); BitBtn.Kind := kind; BitBtn.Glyph.Assign(bm2); LockWindowUpdate(0); Bm2.Free; Result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin InitStdBitBtn(BitBtn1, bkOk); end; Вопрос: Создание PolyPolygon используя массив точек? Ответ: Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.
Пример: procedure TForm1.Button1Click(Sender: TObject); var ptArray : array[0..9] of TPOINT; PtCounts : array[0..1] of integer; begin PtArray[0] := Point(0, 0); PtArray[1] := Point(0, 100); PtArray[2] := Point(100, 100); PtArray[3] := Point(100, 0); PtArray[4] := Point(0, 0); PtCounts[0] := 5; PtArray[5] := Point(25, 25); PtArray[6] := Point(25, 75); PtArray[7] := Point(75, 75); PtArray[8] := Point(75, 25); PtArray[9] := Point(25, 25); PtCounts[1] := 5; PolyPolygon(Form1.Canvas.Handle, PtArray,PtCounts,2); end; Вопрос: Как создать невизуальный компонент без иконоки, которая изображается в палитре компонентов в "design-time" (вроде TField)?
Ответ: Невизуальные компоненты без иконоки удобны для субкомпонентов, связанных с какими-то другими компонентами. Создайте компонент как обычно, но используйте RegisterNoIcon вместо RegisterComponent.
Вопрос: Как показывать нестандартный встроенный редактор (inplace editor) в ячейке stringgrid (например combobox).
Ответ: См. пример Пример: procedure TForm1.FormCreate(Sender: TObject); begin {Высоту combobox'а не изменишь, так что вместо combobox'а будем изменять высоту строки grid'а !} StringGrid1.DefaultRowHeight := ComboBox1.Height; {Спрятать combobox} ComboBox1.Visible := False; ComboBox1.Items.Add('Delphi Kingdom'); ComboBox1.Items.Add('Королевство Дельфи'); end; procedure TForm1.ComboBox1Change(Sender: TObject); begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex]; ComboBox1.Visible := False; StringGrid1.SetFocus; end; procedure TForm1.ComboBox1Exit(Sender: TObject); begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex]; ComboBox1.Visible := False; StringGrid1.SetFocus; end; procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); var R: TRect; begin if ((ACol = 3) AND (ARow <> 0)) then begin {Ширина и положение ComboBox должно соответствовать ячейке StringGrid} R := StringGrid1.CellRect(ACol, ARow); R.Left := R.Left + StringGrid1.Left; R.Right := R.Right + StringGrid1.Left; R.Top := R.Top + StringGrid1.Top; R.Bottom := R.Bottom + StringGrid1.Top; ComboBox1.Left := R.Left + 1; ComboBox1.Top := R.Top + 1; ComboBox1.Width := (R.Right + 1) - R.Left; ComboBox1.Height := (R.Bottom + 1) - R.Top; {Покажем combobox} ComboBox1.Visible := True; ComboBox1.SetFocus; end; CanSelect := True; end; Вопрос: Как узнать есть ли в заданном CD-ROM'е Audio CD? Ответ: Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример: function IsAudioCD(Drive : char) : bool; var DrivePath : string; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; VolumeName : string; Begin sult := false; DrivePath := Drive + ':\'; if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then exit; SetLength(VolumeName, 64); GetVolumeInformation(PChar(DrivePath),PChar(VolumeName), Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0); if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true; end; function PlayAudioCD(Drive : char) : bool; var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; if not IsAudioCD(Drive) then exit; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Shareable := true; mp.Open; Application.ProcessMessages; mp.Play; Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin if not PlayAudioCD('D') then ShowMessage('Not an Audio CD'); end; Вопрос: Как узнать есть ли у мыши колесико? Ответ: Свойство "WheelPresent" глобального обьекта "mouse". Вопрос: События KeyPress и KeyDown не вызываются для клавиши Tab - как определить, что она была нажата?
Ответ: На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
Пример: type TForm1 = class(TForm) private procedure CMDialogKey( Var msg: TCMDialogKey ); message CM_DIALOGKEY; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.CMDialogKey(var msg: TCMDialogKey); begin if msg.Charcode <> VK_TAB then inherited; end; procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_TAB then Form1.Caption := 'Tab Key Down!'; end; Вопрос: В чем отличие между Create(Self) и Create(Application)? Ответ: Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца.
Вопрос: Как во время выполнения определить поддерживает ли обьект заданное свойство? Ответ: function HasProperty(Obj : TObject; Prop : string) : PPropInfo; begin Result := GetPropInfo(Obj.ClassInfo, Prop); end; procedure TForm1.Button1Click(Sender: TObject); var p : pointer; begin p := HasProperty(Button1, 'Color'); if p <> nil then SetOrdProp(Button1, p, clRed) else ShowMessage('Button has no color property'); p := HasProperty(Label1, 'Color'); if p <> nil then SetOrdProp(Label1, p, clRed) else ShowMessage('Label has no color property'); p := HasProperty(Label1.Font, 'Color'); if p <> nil then SetOrdProp(Label1.Font.Color, p, clBlue) else ShowMessage('Label.Font has no color property'); end; Вопрос: Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд? Ответ: В примере время выводится по таймеру. Пример: uses MMSystem; procedure TForm1.Timer1Timer(Sender: TObject); var Trk : Word; Min : Word; Sec : Word; begin with MediaPlayer1 do begin Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position); Sec := MCI_TMSF_SECOND(Position); Label1.Caption := Format('%.2d',[Trk]); Label2.Caption := Format('%.2d:%.2d',[Min,Sec]); end; end; Вопрос: Можно ли рисовать на рамке формы? Ответ: Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией толщиной в 1 пиксел. Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCPaint(var Msg: TWMNCPaint); var dc : hDc; Pen : hPen; OldPen : hPen; OldBrush : hBrush; begin inherited; dc := GetWindowDC(Handle); msg.Result := 1; Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0)); OldPen := SelectObject(dc, Pen); OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH)); Rectangle(dc, 0,0, Form1.Width, Form1.Height); SelectObject(dc, OldBrush); SelectObject(dc, OldPen); DeleteObject(Pen); ReleaseDC(Handle, Canvas.Handle); end; Вопрос: Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением? Ответ: Создайте процедуру, которая будет вызываться при событии Application.OnIdle. Обьявим процедуру: {Private declarations} procedure IdleEventHandler(Sender: TObject; var Done: Boolean); В разделе implementation опишем поцедуру: procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean); begin {Do a small bit of work here} Done := false; end; В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии Application.OnIdle. Application.OnIdle := IdleEventHandler; Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не присвоенно значение True.
Вопрос: При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?
Ответ: Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.
Вопрос: Как разместить маленькие картинки в компоненте TPopUpMenu? Ответ: В приведенном примере показано как это сделать с использованием функции Windows API SetMenuItemBitmaps(). Эта функция получает handle popup menu, позицию строчки меню куда будет помещена картинка, и два дескриптора(handles) на две картинки (одна из них - картинка которая будет показана когда строка меню доступна, вторая - когда строка меню недоступна).
type TForm1 = class(TForm) PopupMenu1: TPopupMenu; Pop11: TMenuItem; Pop21: TMenuItem; Pop31: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} bmUnChecked : TBitmap; bmChecked : TBitmap; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin bmUnChecked := TBitmap.Create; bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP'); bmChecked := TBitmap.Create; bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP'); {Add the bitmaps to the item at index 1 in PopUpMenu} SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle, BmChecked.Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin bmUnChecked.Free; bmChecked.Free; end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var pt : TPoint; begin pt := ClientToScreen(Point(x, y)); PopUpMenu1.Popup(pt.x, pt.y); end; Вопрос: Как узнать число кадров AVI файла, и выяснить как долго будет проигрывться этот файл? Ответ: В приведенном примере указано как получить эту информацию. Пример: procedure TForm1.Button1Click(Sender: TObject); begin MediaPlayer1.TimeFormat := tfFrames; ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length)); MediaPlayer1.TimeFormat := tfMilliseconds; ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length)); end; Вопрос: Как изменить число фиксированных колонок в TDbGrid? Пример: procedure TForm1.Button1Click(Sender: TObject); begin TStringGrid(DbGrid1).FixedCols := 2; end; Вопрос: Некоторые компоненты баз данных (и среди них TDBGrid) никак не меняют визуальных свойств, когда к ним отключен доступ (disabled). Как это изменить програмно?
Ответ: Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).
procedure TForm1.Button1Click(Sender: TObject); begin DbGrid1.Enabled := false; DbGrid1.Font.Color := clGray; end; procedure TForm1.Button2Click(Sender: TObject); begin DbGrid1.Enabled := true; DbGrid1.Font.Color := clBlack; end; Вопрос: Как определить нажаты ли клавиши Shift, Alt, or Ctrl в какой-либо момент времени? Ответ: В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, Ctrl.
Пример: function CtrlDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Control] And 128) <> 0); end; function ShiftDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Shift] and 128) <> 0); end; function AltDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Menu] and 128) <> 0); end; procedure TForm1.MenuItem12Click(Sender: TObject); begin if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := ''; end; Вопрос: Как изменить шрифта hint'а? Ответ: В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а. Пример: type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private {Private declarations} public procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo); {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); var i : integer; begin for i := 0 to Application.ComponentCount - 1 do if Application.Components[i] is THintWindow then with THintWindow(Application.Components[i]).Canvas do begin Font.Name:= 'Arial'; Font.Size:= 18; Font.Style:= [fsBold]; HintInfo.HintColor:= clWhite; end; end; procedure TForm1.FormCreate(Sender: TObject); begin Application.OnShowHint := MyShowHint; end; Вопрос: Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а? Ответ: Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock но не работает для клавиши NumLock.
Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры.
SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно.
Четыре метода "button click" демонстрируют использование: ButtonClick1 - включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.
Пример: 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; Вопрос: Я загружаю TImageList динамически. Как сделать картинки из 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; Вопрос: Как заставить TMediaPlayer проигрывать одно и тоже бесконечно? AVI например? Ответ: В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify Пример: procedure TForm1.MediaPlayer1Notify(Sender: TObject); begin with MediaPlayer1 do if NotifyValue = nvSuccessful then begin Notify := True; Play; end; end; Вопрос: При выполнении диалога FontDialog со свойством Device равным fdBoth or fdPrinter, появляется ошибка "There are no fonts installed".
Ответ: Эти установки должны показать шрифты совместимые либо с принтером либо с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы показать список шрифтов, совместимых одновременно и с экраном и с принтером.
Пример: uses Printers, CommDlg; procedure TForm1.Button1Click(Sender: TObject); var cf : TChooseFont; lf : TLogFont; tf : TFont; begin if PrintDialog1.Execute then begin GetObject(Form1.Canvas.Font.Handle, sizeof(lf),@lf); FillChar(cf, sizeof(cf), #0); cf.lStructSize := sizeof(cf); cf.hWndOwner := Form1.Handle; cf.hdc := Printer.Handle; cf.lpLogFont := @lf; cf.iPointSize := Form1.Canvas.Font.Size * 10; cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG; cf.rgbColors := Form1.Canvas.Font.Color; if ChooseFont(cf) <> false then begin tf := TFont.Create; tf.Handle := CreateFontIndirect(lf); tf.COlor := cf.RgbColors; Form1.Canvas.Font.Assign(tf); tf.Free; Form1.Canvas.TextOut(10, 10, 'Test'); end; end; end; Вопрос: Как сменить дисковод, откуда MediaPlayer проигрывает аудио CD? Ответ: См. пример. Пример: MediaPlayer1.FileName := 'E:'; Вопрос: Как убрать кнопку с названием моей программы из Панели Задач(Taskbar)? Ответ: Отредактируйте файл-проекта (View -> Project Source) Добавьте модуль Windows в раздел uses. Application.ShowMainForm := False; в строку после "Application.Initialize;". Добавьте ShowWindow(Application.Handle, SW_HIDE); в строку перед "Application.Run;"
Ваш файл проекта должен выглядеть приблизительно так: program Project1; uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}, Unit2 in 'Unit2.pas' {Form2}; {$R *.RES} begin Application.Initialize; Application.ShowMainForm := False; Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); ShowWindow(Application.Handle, SW_HIDE); Application.Run; end. В разделе "initialization" (в самом низу) каждого unit'а добавьте begin ShowWindow(Application.Handle, SW_HIDE); end. Вопрос: Как преобразовать цвета в строку - название цвета VCL? Ответ: Модуль graphics.pas содержит функцию ColorToString() которое преобразует допустимое значение TColor в его строковое представление используя либо константу-название цвета (по возможности) либо шестнадцатиричную строку. Обратная функция - StringToColor()
Пример: procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(ColorToString(clRed)); Memo1.Lines.Add(IntToStr(StringToColor('clRed'))); end; Вопрос: При показе максимизированное формы она перекрывает task bar и не выравнивается по верху экрана. В чем тут дело? Ответ: Это может произойти когда свойство position формы установленно в poScreenCenter. Установите position = poDefault. Вопрос: Как заставить TEdit не 'пикать' при нажатии недопустимых клавиш? Ответ: Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш. Пример: procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then Key := #0; end; Вопрос: Как получить число и список всех компонентов, расположенных на TNoteBook? Ответ: В примере список выводится на Listbox. Пример: procedure TForm1.Button1Click(Sender: TObject); var n: integer; p: integer; begin ListBox1.Clear; with Notebook1 do begin for n := 0 to ControlCount - 1 do begin with TPage(Controls[n]) do begin ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption); for p := 0 to ControlCount - 1 do ListBox1.Items.Add(Controls[p].Name); ListBox1.Items.Add(EmptyStr); end; end; end; end; Вопрос: Я хочу вставить escape code в строку при использовании функции Format(). Например, я хочу создать строку, содержащую символ табуляции. В "C" я бы написал что-то вроде sprintf(buffer, "%s\t%s", str);. А как это будет на Pascal'e?
Ответ: Функция Format Pascal'я не использует escape codes. Вместо этого нужно вставить в строку действительное значение символа в кодировке ASCII.
Пример: Buffer := Format('%s'#9'%s', [Str1, Str2]); ShowMessage(Format('%s'#9'%s', ['Column1', 'Column2'])); Вопрос: Как показать первый кадр AVI-файла? Ответ: См. пример. Пример: procedure TForm1.Button1Click(Sender: TObject); begin Application.ProcessMessages; MediaPlayer1.Open; Application.ProcessMessages; MediaPlayer1.Step; Application.ProcessMessages; MediaPlayer1.Previous; end; Вопрос: Когда пользователь щелкает по listview, он переходит в режим редактирования. Как перевисти его в редим редактирования по нажатию клавиши (например F2)? Ответ: Перехватите F2 на событии keydown. Пример: procedure TForm1.ListView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Ord(Key) = VK_F2 then ListView1.Selected.EditCaption; end; Вопрос: Когда я добавляю обьект в список TStrings как мне его потом уничтожить? Ответ: Просто вызовите метод free этого обьекта. Пример: procedure TForm1.FormCreate(Sender: TObject); var Icon: TIcon; begin Icon := TIcon.Create; Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO'); ListBox1.Items.AddObject('Item 0', Icon); end; procedure TForm1.FormDestroy(Sender: TObject); begin ListBox1.Items.Objects[0].Free; end; Вопрос: Вместо печати графики я хочу использовать резидентный шрифт принтера. Как? Ответ: Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.
Пример: uses Printers; procedure TForm1.Button1Click(Sender: TObject); var tm : TTextMetric; i : integer; begin if PrintDialog1.Execute then begin Printer.BeginDoc; Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT); GetTextMetrics(Printer.Canvas.Handle, tm); for i := 1 to 10 do begin Printer.Canvas.TextOut(100,i * tm.tmHeight + tm.tmExternalLeading,'Test'); end; Printer.EndDoc; end; end; Вопрос: Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?
Ответ: Эту информацию можно получить из реестра. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false); ShowMessage(reg.ReadString('SourcePath')); reg.CloseKey; reg.free; end; Вопрос: Как получить строку сообщения об ошибке Windows код которой получен функцией GetLastError? Ответ: Функция RTL SysErrorMessage(GetLastError). Пример: procedure TForm1.Button1Click(Sender: TObject); begin {Cause a Windows system error message to be logged} ShowMessage(IntToStr(lStrLen(nil))); ShowMessage(SysErrorMessage(GetLastError)); end; Вопрос: Как заставить Delphi выполнять еще более строгую проверка типов? Напрмер - я создаю пользовательский тип, унаследованный от double и могу передавать его любым функциям, принимающим параметр типа double. Как заставить компилятор проводить более строгую проверку типов и выдавать предупреждение в таких случаях?
Ответ: См. ответ. Пример: type TStrongType = type Double; type TWeakType = Double; procedure AddWeakType(var d : TWeakType); begin d := d + 1; end; procedure AddStrongType(var d : TStrongType); begin d := d + 1; end; procedure AddDoubleType(var d : Double); begin d := d + 1; end; procedure TForm1.Button1Click(Sender: TObject); var d : Double; s : TStrongType; w : TWeakType; begin AddDoubleType(d); {compiles fine} AddDoubleType(w); {compiles fine} AddDoubleType(s); { Вопрос: Где в Delphi обьявленны VK_Key для A-Z и 0-9? Ответ: Они не обьявлены в Delphi поскольку они просто могуть быть заменены буквами. VK_0 до VK_9 то же что и ASCII '0' до '9' ($30 - $39), VK_A до VK_Z то же что и ASCII 'A' до 'Z' ($41 - $5A). Вопрос: Как изменить оконную процедуру для TForm? Ответ: Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.
Пример: type TForm1 = class(TForm) Button1: TButton; procedure WndProc (var Message: TMessage); override; procedure Button1Click(Sender: TObject); private {Private declarations} public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WndProc (var Message: TMessage); begin if Message.Msg = WM_CANCELMODE then begin Form1.Caption := 'A dialog or message box has popped up'; end else inherited // Вопрос: Как узнать размеры TComboBox с показанным выпадающим списком до показа списка? Ответ: На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды - один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient чтобы преобразовать экранные кординаты в координаты клиентской области окна.
Пример: var R : TRect; procedure TForm1.FormShow(Sender: TObject); var T : TPoint; begin SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0); SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0); SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r)); t := ScreenToClient(Point(r.Left, r.Top)); r.Left := t.x; r.Top := t.y; t := ScreenToClient(Point(r.Right, r.Bottom)); r.Right := t.x; r.Bottom := t.y; end; procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom ); end; Вопрос: Я хочу создать в своей программе меню "а ля Дельфи 4". Как это сделать? Ответ: 1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client. 2. Разместите TToolBar (закладка Win32) внутри TControlBar. 3. Установите в True свойства Flat и ShowCaptions этого TToolBar. 4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton) 5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между главными пунктами меню (если меню уже показано). 6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu формы). 7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer) 8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu. Вопрос: Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов, но и в режиме замены? Ответ: Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".
Пример: type TForm1 = class(TForm) Memo1: TMemo; procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1KeyPress(Sender: TObject; var Key: Char); private {Private declarations} InsertOn : bool; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key = VK_INSERT) and (Shift = []) then InsertOn := not InsertOn; end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin if ((Memo1.SelLength = 0) and (not InsertOn)) then Memo1.SelLength := 1; end; Вопрос: Как отправить сообщение сразу всем элементам управления формы? Ответ: Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.
Вопрос: При попытке присвоить значение свойству "selected" ListBox'а вырабатывается exception "Index is out of bounds". В чем тут дело и как присвоить значение свойству selected? Ответ: Свойство "selected" компонента ТListBox может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex. Пример: procedure TForm1.Button1Click(Sender: TObject); begin ListBox1.Items.Add('1'); ListBox1.Items.Add('2'); {This will fail on a single selection ListBox} // ListBox1.Selected[1] := true; ListBox1.ItemIndex := 1; {This is ok} end; Вопрос: Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину TEdit'а? Ответ: В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример: procedure TForm1.FormCreate(Sender: TObject); var cRect : TRect; bm : TBitmap; s : string; begin Windows.GetClientRect(Edit1.Handle, cRect); bm := TBitmap.Create; bm.Width := cRect.Right; bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font; s := 'W'; while bm.Canvas.TextWidth(s) < CRect.Right do s := s + 'W'; if length(s) > 1 then begin Delete(s, 1, 1); Edit1.MaxLength := Length(s); end; end; {Другой вариант} procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); var cRect : TRect; bm : TBitmap; begin if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then begin Windows.GetClientRect(Edit1.Handle, cRect); bm := TBitmap.Create; bm.Width := cRect.Right; bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font; if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then begin Key := #0; MessageBeep(-1); end; bm.Free; end; end; Вопрос: Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных? Ответ: Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра
Uses ... Registry; procedure SaveFontToRegistry(Font : TFont; SubKey : String); Var R : TRegistry; FontStyleInt : byte; FS : TFontStyles; begin R:=TRegistry.Create; try FS:=Font.Style; Move(FS,FontStyleInt,1); R.OpenKey(SubKey,True); R.WriteString('Font Name',Font.Name); R.WriteInteger('Color',Font.Color); R.WriteInteger('CharSet',Font.Charset); R.WriteInteger('Size',Font.Size); R.WriteInteger('Style',FontStyleInt); finally R.Free; end; end; function ReadFontFromRegistry(Font : TFont; SubKey : String) : boolean; Var R : TRegistry; FontStyleInt : byte; FS : TFontStyles; begin R:=TRegistry.Create; try result:=R.OpenKey(SubKey,false); if not result then exit; Font.Name:=R.ReadString('Font Name'); Font.Color:=R.ReadInteger('Color'); Font.Charset:=R.ReadInteger('CharSet'); Font.Size:=R.ReadInteger('Size'); FontStyleInt:=R.ReadInteger('Style'); Move(FontStyleInt,FS,1); Font.Style:=FS; finally R.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin If FontDialog1.Execute then begin SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts'); end; end; procedure TForm1.Button2Click(Sender: TObject); var NFont : TFont; begin NFont:=TFont.Create; if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then begin //здесь добавить проверку - существует ли шрифт Label1.Font.Assign(NFont); NFont.Free; end; end; Вопрос: Как перемещать компонент мышкой во время работы программы "runtime"? Ответ: Перехватить событие OnMouseDown, запомнить x и y координты курсора мыши. Отслеживать движение мыши по событию OnMouseMove и перемещать компонент вслед за курсором мыши до тех пор пока не произойдет событие OnMouseUp. В примере показано перемещение компонента TButton. Перемещение начинается, когда пользователь "берет" TButton мышью, удерживая нажатой клавишу "Сontrol".
Пример: type TForm1 = class(TForm) Button1: TButton; procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} public {Public declarations} MouseDownSpot : TPoint; Capturing : bool; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if ssCtrl in Shift then begin SetCapture(Button1.Handle); Capturing := true; MouseDownSpot.X := x; MouseDownSpot.Y := Y; end; end; procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); end; end; procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin ReleaseCapture; Capturing := false; Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); end; end; Вопрос: При попытке создать обьект класса TPrinter (TPrinter.Create) я получаю exception. Почему? Ответ: В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости, так как обьект класса TPrinter (называемый Printer) автоматически создается при использовании модуля Printers. Пример: uses Printers; procedure TForm1.Button1Click(Sender: TObject); begin Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Hello World!'); Printer.EndDoc; end; Вопрос: Как перехватить события в неклиентской области формы, в заголовке окна, например? Ответ: Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок). Пример: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) private {Private declarations} procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage); var s : string; begin case Message.wParam of HTERROR: s:= 'HTERROR'; HTTRANSPARENT: s:= 'HTTRANSPARENT'; HTNOWHERE: s:= 'HTNOWHERE'; HTCLIENT: s:= 'HTCLIENT'; HTCAPTION: s:= 'HTCAPTION'; HTSYSMENU: s:= 'HTSYSMENU'; HTSIZE: s:= 'HTSIZE'; HTMENU: s:= 'HTMENU'; HTHSCROLL: s:= 'HTHSCROLL'; HTVSCROLL: s:= 'HTVSCROLL'; HTMINBUTTON: s:= 'HTMINBUTTON'; HTMAXBUTTON: s:= 'HTMAXBUTTON'; HTLEFT: s:= 'HTLEFT'; HTRIGHT: s:= 'HTRIGHT'; HTTOP: s := 'HTTOP'; HTTOPLEFT: s:= 'HTTOPLEFT'; HTTOPRIGHT: s:= 'HTTOPRIGHT'; HTBOTTOM: s:= 'HTBOTTOM'; HTBOTTOMLEFT: s:= 'HTBOTTOMLEFT'; HTBOTTOMRIGHT: s:= 'HTBOTTOMRIGHT'; HTBORDER: s:= 'HTBORDER'; HTOBJECT: s:= 'HTOBJECT'; HTCLOSE: s:= 'HTCLOSE'; HTHELP: s:= 'HTHELP'; else s:= ''; end; Form1.Caption := s; Message.Result := 0; end; end. Вопрос: При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку увеличенной ее размер не изменяется. Что делать? Ответ: Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw. Пример: procedure TForm1.Button1Click(Sender: TObject); var TheBitmap : TBitmap; begin TheBitmap := TBitmap.Create; TheBitmap.Width := Application.Icon.Width; TheBitmap.Height := Application.Icon.Height; TheBitmap.Canvas.Draw(0, 0, Application.Icon); Form1.Canvas.StretchDraw(Rect(0,0,TheBitmap.Width * 3,TheBitmap.Height * 3), TheBitmap); TheBitmap.Free; end; Вопрос: Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы вместить самую длинную строчку в колонке? Ответ: См. пример. Пример: procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer); var i : integer; temp : integer; max : integer; begin max := 0; for i := 0 to (Grid.RowCount - 1) do begin temp := Grid.Canvas.TextWidth(grid.cells[column, i]); if temp > max then max := temp; end; Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3; end; procedure TForm1.Button1Click(Sender: TObject); begin AutoSizeGridColumn(StringGrid1, 1); end; Вопрос: TTimer работает не достаточно точно. Как получить более высокую точность? Ответ: Таймер Windows не был создан с целью получения сверхточного хронометра. :-( Другими словами, когда Вы устанавливаете таймер на срабатывания каждые 1000 миллисекунд, он может срабатывать через интервал несколько больший чем 1000 миллисекунд. Значения меньше 55 миллисекунд никогда не будут срабатывать вовремя в Windows, поскольку это минимальная точность таймера. Можно проверять системное время и сравнивать его со временем предыдущего события таймера чтобы повысить точность.
Вопрос: Как поместить JPEG-картинку в exe-файл и потом загрузить ее? Ответ: 1) Создайте текстовый файл с расширением ".rc". Имя этого файла должно отличаться от имени файла-пректа или любого модуля проекта. Файл должен содержать строку вроде: MYJPEG JPEG C:\DownLoad\MY.JPG где: "MYJPEG" имя ресурса "JPEG" пользовательский тип ресурса "C:\DownLoad\MY.JPG" руть к JPEG файлу. Пусть например rc-файл называется "foo.rc" Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь к rc-файлу. В нашем примере: C:\DelphiPath\BIN\BRCC32.EXE C:\ProjectPath\FOO.RC Вы получите откомпилированный ресурс - файл с расширением ".res". (в нашем случает foo.res). Далее добавте ресурс к своему приложению. {Грузим ресурс} {$R FOO.RES} uses Jpeg; procedure LoadJPEGFromRes(TheJPEG : string; ThePicture : TPicture); var ResHandle : THandle; MemHandle : THandle; MemStream : TMemoryStream; ResPtr : PByte; ResSize : Longint; JPEGImage : TJPEGImage; begin ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG'); MemHandle := LoadResource(hInstance, ResHandle); ResPtr := LockResource(MemHandle); MemStream := TMemoryStream.Create; JPEGImage := TJPEGImage.Create; ResSize := SizeOfResource(hInstance, ResHandle); MemStream.SetSize(ResSize); MemStream.Write(ResPtr^, ResSize); FreeResource(MemHandle); MemStream.Seek(0, 0); JPEGImage.LoadFromStream(MemStream); ThePicture.Assign(JPEGImage); JPEGImage.Free; MemStream.Free; end; procedure TForm1.Button1Click(Sender: TObject); begin LoadJPEGFromRes('MYJPEG', Image1.Picture); end; Вопрос: Как перехватить сообщения прокрутки в TScrollBox? Ответ: Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и синхронизирует обе линейки прокрутки. Сообщения прокрутки перехватываются с помощью переопределения окнной процедуры (WinProc) ScrollBox'а. Пример: type {$IFDEF WIN32} WParameter = LongInt; {$ELSE} WParameter = Word; {$ENDIF} LParameter = LongInt; {Declare a variable to hold the window procedure we are replacing} var OldWindowProc : Pointer; function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} var TheRangeMin : integer; TheRangeMax : integer; TheRange : integer; begin if TheMessage = WM_VSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax); {Get the vertical scroll box position} TheRange := GetScrollPos(WindowHandle, SB_VERT); {Make sure we wont exceed the range} if TheRange < TheRangeMin then TheRange := TheRangeMin else if TheRange > TheRangeMax then TheRange := TheRangeMax; {Set the horizontal scroll bar} SetScrollPos(WindowHandle, SB_HORZ, TheRange, true); end; if TheMessage = WM_HSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax); {Get the horizontal scroll box position} TheRange := GetScrollPos(WindowHandle, SB_HORZ); {Make sure we wont exceed the range} if TheRange < TheRangeMin then TheRange := TheRangeMin else if TheRange > TheRangeMax then TheRange := TheRangeMax; {Set the vertical scroll bar} SetScrollPos(WindowHandle, SB_VERT, TheRange, true); end; {Call the old Window procedure to allow processing of the message.} NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL); end; procedure TForm1.FormCreate(Sender: TObject); begin {Set the new window procedure for the control and remember the old window procedure.} OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Set the window procedure back to the old window procedure.} SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc)); end; Вопрос: Как сделать прямоугольник для выделения части картинки для редактирования? Ответ: Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример: type TForm1 = class(TForm) procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} Capturing : bool; Captured : bool; StartPlace : TPoint; EndPlace : TPoint; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect; begin if pt1.x < pt2.x then begin Result.Left := pt1.x; Result.Right := pt2.x; end else begin Result.Left := pt2.x; Result.Right := pt1.x; end; if pt1.y < pt2.y then begin Result.Top := pt1.y; Result.Bottom := pt2.y; end else begin Result.Top := pt2.y; Result.Bottom := pt1.y; end; end; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Captured then DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); StartPlace.x := X; StartPlace.y := Y; EndPlace.x := X; EndPlace.y := Y; DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); Capturing := true; Captured := true; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); EndPlace.x := X; EndPlace.y := Y; DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); end; end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Capturing := false; end; Вопрос: Можно ли использовать иконку как картинку на кнопке TSpeedButton? Ответ: Можно. См. пример. Пример: uses ShellApi; procedure TForm1.FormShow(Sender: TObject); var Icon: TIcon; begin Icon := TIcon.Create; Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1); SpeedButton1.Glyph.Width := Icon.Width; SpeedButton1.Glyph.Height := Icon.Height; SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon); Icon.Free; end; Вопрос: Как поместить прозрачную фоновую каринку на компонент CoolBar? Ответ: procedure TForm1.Button1Click(Sender: TObject); var Bm1 : TBitmap; Bm2 : TBitmap; begin Bm1 := TBitmap.Create; Bm2 := TBitmap.Create; Bm1.LoadFromFile('c:\download\test.bmp'); Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; bm2.Canvas.Brush.Color := CoolBar1.Color; bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), ClWhite); bm1.Free; CoolBar1.Bitmap.Assign(bm2); bm2.Free; end; Вопрос: Ползунок компонента TScrollBar все время мигает. Как это отключить? Ответ: Установите свойтсво ScrollBar.TabStop в False. Вопрос: Как программно перевести DBgrid в реим редактирования и установить курсор в окошке редактирования в требуемую позицию? Ответ: Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.
Пример: procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin Application.ProcessMessages; DbGrid1.SetFocus; DbGrid1.EditorMode := true; Application.ProcessMessages; h:= Windows.GetFocus; SendMessage(h, EM_SETSEL, 2, 2); end; Вопрос: Как поместить курсор в определенную позицию edit'а и подобных ему элементов управления? Ответ: Можно использовать методы Delphi SelStart() и SelectLength(). Пример: procedure TForm1.Button1Click(Sender: TObject); begin Edit1.SetFocus; {переводим курсор во вторую позицию} Edit1.SelStart := 2; {не выделяем никакого текста} Edit1.SelLength := 0; end; Вопрос: Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение размера формы? Ответ: В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о минимизации или максимизации формы - пищит динамик. Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMSysCommand; begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0) else inherited; end; Вопрос: Можно ли сделать так - одна форма показывает другую и остается позади нее, но фокус ввода не переходит к новой форме, а остается у старой? Ответ: В примере показывается не автосоздаваемая (non auto-created) форма, но фокус ввода ей не передается. Пример: uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Form2 := TForm2.Create(Application); Form2.Visible := FALSE; ShowWindow(Form2.Handle, SW_SHOWNA); end; Вопрос: На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены? Ответ: В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода. Пример: procedure TForm1.FormCreate(Sender: TObject); var i : integer; OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); i := 0; while i 0 then DriveComboBox1.Items.Delete(i) else inc(i); end; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; Вопрос: Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений? Ответ: Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms. Пример: {Code for Unit1} const UM_MyGlobalMessage = WM_USER + 1; type TForm1 = class(TForm) Label1: TLabel; Button1: TButton; procedure FormShow(Sender: TObject); procedure Button1Click(Sender: TObject); private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage); message UM_MyGlobalMessage; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} uses Unit2; procedure TForm1.FormShow(Sender: TObject); begin Form2.Show; end; procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage); begin Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form1.Caption := 'Got It!'; end; procedure TForm1.Button1Click(Sender: TObject); var f: integer; begin for f := 0 to Screen.FormCount - 1 do Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42); end; {Code for Unit2} const UM_MyGlobalMessage = WM_USER + 1; type TForm2 = class(TForm) Label1: TLabel; private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage); message UM_MyGlobalMessage; public {Public declarations} end; var Form2: TForm2; implementation {$R *.DFM} procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage); begin Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form2.Caption := 'Got It!'; end; Вопрос: Как обновить список дисков компонента TDriveComboBox, учитывая, что могуд быть подключены/отключены сетевые диски и произведена "горячая замена" plug&play дисков? Ответ: Следующий пример вызывает защищенный (protected) метод класса TDriveComboBox BuildList() для регеирации списка дисков. (использовая так наз. "class cracer") Пример: type TNewDriveComboBox = class(TDriveComboBox) //это наш "class cracer" end; procedure TForm1.Button1Click(Sender: TObject); var Drive : char; begin Drive := DriveComboBox1.Drive; TNewDriveComboBox(DriveComboBox1).BuildList; //вызываем защищенный метод родительского класса DriveComboBox1.Drive := Drive; end; Вопрос: Как программно заставить выпасть меню? Ответ: В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.
Пример: procedure TForm1.Button1Click(Sender: TObject); begin //Allow button to finish painting in response to the click Application.ProcessMessages; {Alt Key Down} keybd_Event(VK_MENU, 0, 0, 0); {F Key Down - Drops the menu down} keybd_Event(ord('F'), 0, 0, 0); {F Key Up} keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0); {Alt Key Up} keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0); {F Key Down} keybd_Event(ord('S'), 0, 0, 0); {F Key Up} keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0); end; Вопрос: Как сделать клавишу-акселератор (keyboard shortcut) компонету у которого нет заголовка? Ответ: Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонет TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, перевидите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.
Пример: procedure TForm1.FormCreate(Sender: TObject); begin Label1.Visible := false; Label1.Caption := '&M'; Label1.FocusControl := Memo1; end; Вопрос: Можно ли как-то уменьшить мерцание при перерисовке компонента? Ответ: Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет. Пример: constructor TMyControl.Create; begin inherited; ControlStyle := ControlStyle + [csOpaque]; end; Вопрос: Как запретить изменение размера моего компонента в design-time? Ответ: Поместите в конструктор компонента код, устанавливающий размеры по умолчанию. Переопределите метод SetBounds и проверяйте в нем "componentstate". Если компонет находится режиме "design-time" (csDesigning in ComponentState) просто передавайте значения ширины и высоты (width и heights) компонента по умолчанию (в нашем примере 50) методу класса-предка. Пример: procedure TVu.SetBounds(ALeft : integer; ATop : integer; AWidth : integer; AHeight : integer); begin if csdesigning in componentstate then begin AWidth := 50; AHeight := 50; inherited; //вызываем унаследованный от предка метод end; end; Вопрос: Можно ли уменьшить потребляемые компонентами TNotebook и TTabbedNotebook ресурсы? Ответ: Да. Можно уничтожать обьекты, расположенные не на текущей странице TNotebook или TTabbedNotebook. В примере вызывается защищенный (Protected) метод путем создания так называемый "class cracer'ов". type TMyTabbedNotebook = class(TTabbedNotebook); //это наш "class cracer" type TMyNotebook = class(TNotebook); procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean); begin with TabbedNotebook1 do //вызываем защищенный метод родительского класса TMyTabbedNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle; end; procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean); begin with Notebook1 do //вызываем защищенный метод родительского класса TMyNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle; NoteBook1.PageIndex := NewTab; AllowChange := true end; Вопрос: Функция keybd_event() принимает значения до 244 - как мне отправить нажатие клавиши с кодом #255 в элемент управления Windows? Ответ: Это может понадобится для иностранных языков или для специальных символов. (например, в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод, не стоит использовать в случае если символ может быть передан обычным способом (функцией keybd_event()). procedure TForm1.Button1Click(Sender: TObject); var KeyData : packed record RepeatCount : word; ScanCode : byte; Bits : byte; end; begin {Let the button repaint} Application.ProcessMessages; {Set the focus to the window} Edit1.SetFocus; {Send a right so the char is added to the end of the line} // SimulateKeyStroke(VK_RIGHT, 0); keybd_event(VK_RIGHT, 0,0,0); {Let the app get the message} Application.ProcessMessages; FillChar(KeyData, sizeof(KeyData), #0); KeyData.ScanCode := 255; KeyData.RepeatCount := 1; SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData)); KeyData.Bits := KeyData.Bits or (1 shl 30); KeyData.Bits := KeyData.Bits or (1 shl 31); SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData)); KeyData.Bits := KeyData.Bits and not (1 shl 30); KeyData.Bits := KeyData.Bits and not (1 shl 31); SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData)); Application.ProcessMessages; end; Вопрос: Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не сдвинет мышь. Как эмулировать движение мыши? Ответ: В примере мышка слегка "подталкивается" без участия пользователя. procedure TForm1.Button1Click(Sender: TObject); var pt : TPoint; begin Application.ProcessMessages; Screen.Cursor := CrHourglass; GetCursorPos(pt); SetCursorPos(pt.x + 1, pt.y + 1); Application.ProcessMessages; SetCursorPos(pt.x - 1, pt.y - 1); end; Вопрос: Как зарегистрировать расширение файла за своим приложением и контекстное меню, связанное с этим типом? Ответ: Пример регистрирует расширение файла(.myext) - файлы этого типа будут открываться приложением MyApp.Exe. Также регнстрируется одно действие (action) по умолчанию для файлов этого типа и два дополнительных пункта контекстного меню, связанного с этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения вступили в силу. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var R : TRegIniFile; begin R := TRegIniFile.Create(''); with R do begin RootKey := HKEY_CLASSES_ROOT; WriteString('.myext','','MyExt'); WriteString('MyExt','','Some description of MyExt files'); WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0'); WriteString('MyExt\Shell','','This_Is_Our_Default_Action'); WriteString('MyExt\Shell\First_Action', '','This is our first action'); WriteString('MyExt\Shell\First_Action\command','', 'C:\MyApp.Exe /LotsOfParamaters %1'); WriteString('MyExt\Shell\This_Is_Our_Default_Action','', 'This is our default action'); WriteString('MyExt\Shell\This_Is_Our_Default_Action\command', '','C:\MyApp.Exe %1'); WriteString('MyExt\Shell\Second_Action', '','This is our second action'); WriteString('MyExt\Shell\Second_Action\command', '','C:\MyApp.Exe /TonsOfParameters %1'); Free; end; end;
© 1999 Inprise Corp.
Last Modified Friday, 06-Aug-99 11:12:04 PST.
Translated & Adapted by
19-Sep-1999
Директива компилятора - $INCLUDE
| Раздел Сокровищница |
В своей статье я писал про проблему, возникающую в Object Pascal в связи с только явным подключением заголовочных файлов. Благодаря одному человеку, подсказавшему решение, для меня эта проблема в основом снята. Хочу поделиться решением.
Существует такая директива компилятора - {$INCLUDE filename} и её более короткий аналог {$I filename}. Раньше я недооценивал её значение, т. к. в чужих программах с помощью неё к коду программы подключались либо файлы с процедурами, либо списки ассемблерных команд. Выяснилось, что с помощью этой директивы можно подключать и ссылки на другие файлы программы. Поясню на примере.
В IDE Delphi 5 при создании нового проекта в интерфейсной секции автоматически формируется список uses такого вида:
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
Начинающие ещё не усматривают никакого подвоха в этом (как не замечал этого и я, когда только осваивал программирование), но постепенно с ростом программ список uses, помимо ссылок на стандартные файлы среды, начинает пополняться десятками собственных и грозит распухнуть до гигинтских размеров. Частично её можно решить, если весь код собрать в нескольких файлах, но это неудобно.
Выход один - можно создать отдельный файл - назовём его, например, vcl.pas. После этого модернизируем его так:
| //------------------------------------------------------------------ // Файл: vcl.pas // Описание: Список ссылок на стандартные модули VCL //------------------------------------------------------------------ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs |
Замечу, здесь нет ошибки! Именно так, без всех зарезервированных слов языка, должен выглядеть этот файл. После Dialogs точка с запятой отсутствует.
Теперь в модуле Unit1.pas удаляем все ссылки и пишем:
| uses Activex, // для наглядности {$i vcl}; |
Т. к. расширение по умолчанию - *.pas, его можно не указывать. Что же произошло? Директивой {$i} мы указали компилятору подставить список ссылок в текст модуля Unit1.pas. Получилось
| uses Activex, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; |
Данная директива не решает всех проблем, это ведь не аналог директивы #include из языка С. Например, С позволяет организовать видимость модулей на нескольких уровнях - например, если модуль B включает модуль С, то модуль А, подключив модуль В, получит в своё распоряжение также и данные из модуля С. В нашем случае это недоступно, однако часто это и не требуется. А вот сократить список uses в каждом файле проекта - это может быть полезно.
Диспетчер кучи для объектов одного размера
| й Парунов, дата публикации 23 декабря 02 |
Модуль содержит класс psnFixSzMemMgr, реализующий диспетчер кучи для объектов одного размера.
Динамическое размещение объектов (не только экземпляров классов, а вообще) в куче имеет неоспоримые преимущества: гибкость, простота... Но у такого подхода есть недостаток, проистекающий от всеядности стандартного диспетчера кучи языка (Delphi), который и выбирает, откуда "отщипнуть" кусочек памяти. Уж очень много самых разных блоков выделяется-освобождается в куче, и она превращается в швейцарский сыр. Отсюда вытекают две неприятности. Во-первых, когда выделяется блок памяти, диспетчер вынужден запомнить его размер и прочие параметры в пропадающем зря 4-байтном (чаще всего) заголовке (для освобождения). Во-вторых, уж очень медленен этот процесс - надо перестроить дерево... в общем, тактов 200 на одно выделение/освобождение на процессоре Пентиум 3 обеспечено.
Все эти недостатки проявляются особенно сильно при работе с маленькими динамическими переменными, которые часто так заманчиво применять для различных списков, деревьев, графов... И самое обидное, что вся эта возня - впустую: так как размер переменных нам-то известен, нет необходимости ни в мудрёном отслеживании блоков (можно обойтись простым списком неиспользуемых), ни тем более в запоминании размера каждого выделенного блока. Эти соображения ведут к применению массивов, с которыми нередко достигается наибольшая скорость, но есть и свои сложности: сложность (простите за каламбур) и негибкость. К тому же частое применение индексов в массиве всё же медленнее использования указателей.
Данный класс реализует упрощенный диспетчер кучи для объектов одного размера (назовём его экземпляр кучей), который можно применять вместо стандартного, получая с маленькими объектами существенно большую скорость, а часто и экономию памяти, за счёт реализации старого татаро-монгольского принципа: "меньше чем по десять тысяч мы даже в гости не ходим" ((c) Александр Борянский, Сергей Козлов).
Его применение в основном подобно стандартному:
| type psnFixSzMemMgr = class private FLastCommit, { указатель на последний выделенный массив, в начале которого - указатель на предпоследний...} FEmptyBlock : Pointer; {указатель на последний пустой блок из списка, в начале которого - указатель на предпоследний...} FBlockSize, FCommitSize, FFillCycles: Integer; public constructor Create( const BlockSize: Integer; {Размер выделяемых блоков памяти. Реально округляется в большую сторону до величины, кратной 4.} const CommitBlocks: Integer = 127 {Количество блоков в выделяемых массивах. Должно быть больше 1 (иначе зачем огород городить?), а для скорости желательно не меньше 31. Реально увеличивается до ближайшего сверху нечётного значения (алгоритм требует это для высокой скорости).} ); function FixNew: Pointer; {Выделяет блок памяти размера BlockSize и возвращает ссылку на эту память. Выполнено в виде функции во избежание обязательного преобразования типов параметра, передаваемого по ссылке.} procedure FixDsp(const Ptr: Pointer); {Освобождает блок памяти, выделенный ранее в данном экземпляре класса, указуемый параметром Ptr.} destructor Destroy; override; end; implementation constructor psnFixSzMemMgr.Create(const BlockSize, CommitBlocks: Integer); begin FBlockSize:= (BlockSize + 3) and $7FFFFFFC; FCommitSize:= (CommitBlocks and $7FFFFFFE + 1) * FBlockSize + 4; FFillCycles:= CommitBlocks shr 1 - 1; {заполняем в один присест два блока, и цикл оформим от нуля: for I:= 0 to FFillCycles, быстрее будет} end; function psnFixSzMemMgr.FixNew: Pointer; var P, P2: Pointer; I, DBlockSize: Integer; begin if not Assigned (FEmptyBlock) then begin {выделим массив} GetMem(P, FCommitSize); Pointer(P^):= FLastCommit; FLastCommit:= P; Inc(PChar(P), 4); Pointer(P^):= Nil; P2:= Pointer(Integer(P) + FBlockSize); DBlockSize:= FBlockSize shl 1; for I:= 0 to FFillCycles do begin {надо сделать список пустых блоков} Pointer(P2^):= P; Inc(PChar(P), DBlockSize); Pointer(P^):= P2; Inc(PChar(P2), DBlockSize); end; FEmptyBlock:= P; end; Result:= FEmptyBlock; FEmptyBlock:= Pointer(Result^); end; procedure psnFixSzMemMgr.FixDsp(const Ptr: Pointer); begin Pointer(Ptr^):= FEmptyBlock; FEmptyBlock:= Ptr; end; destructor psnFixSzMemMgr.Destroy; var P: Pointer; begin while Assigned(FLastCommit) do begin P:= FLastCommit; FLastCommit:= Pointer(P^); FreeMem(P, FCommitSize); end; inherited; end; |
Дополнение
й Жолоб (Донецк)01 августа 2002г.
Я до сих пор работаю с Delphi 4, поскольку моего домашнего компьютера как раз хватает для этой версии. Иногда я встречаю интересные проекты, предназначенные для Delphi 5, в которых DFM-файлы имеют текстовый формат. Однако Delphi 4, в отличие от Delphi 5, еще не имеет встроенного распознавателя форматов. Поэтому приходится либо переходить в Delphi 5 (я могу сделать это на работе), либо создавать форму в текстовом режиме (тогда получаются накладки с событиями). Есть, правда утилита convert.exe для преобразования файлов, но она не дает возможности просмотреть содержание DFM файла в текстовом виде. Вот я и решил написать собственную программу для этой цели.
Предлагаю ее всем желающим для свободного использования. Приношу благодарность разработчикам RX Library за возможность использования кода из модуля StrUtils. В "прицепе" - полный исходный код программы.
Проверка текстового DFM-файла проводится согласно алгоритму, использованному Markus Stephan
Скачать исходные коды проекта: (4.8K)
| Раздел Сокровищница |
(начало)
Эта статья о том, что в компоненте ListView существенно нехватает одного свойства и о все той же программе для редактирования файлов с убранными ошибками и более грамотным интерфейсом.
| символа является фиксированной величиной. То есть, ширина задана создателем шрифта для каждого конкретного символа и не зависит от его положения в тексте. Это неизбежно порождает эффект неравномерности при выводе текста на экран, которое не замечает большинство рядовых пользователей, но хорошо известный дизайнерам. Введите, например, в Word-е следующий текст: "AVALLOOOOOLTLTLTL" Обратите внимание, что видимое расстояние между буквами A и V заметно больше, чем между соседними O. С точки зрения компьютера все в порядке - грубо говоря, Windows считает межсимвольным расстоянием разницу между самой правой точкой предыдущего символа и самой левой текущего. Но с точки зрения дизайна - это помарка, которую стандартными средствами исправить невозможно или очень сложно (вручную регулировать межсимвольный интервал в Word-e). К слову сказать, Adobe Photoshop пытается бороться с этим явлением (опция "Auto Kerning"), но не всегда у него получается то, что надо. Например, для Arial приведенный выше текст будет выглядеть хорошо, для Times - не очень и даже "очень не". |
| Как решить |
В прикладных задачах неровности шрифта можно исправить хотя бы частично, если рассчитывать и запоминать расстояния между каждыми парами символов.
Предлагаемый невизуальный компонент позволяет это делать для символов из одного шрифта, запоминая межсимвольные расстояния при инициализации. При настройке объекта на конкретный шрифт, а точнее, канву, задается минимальное межсимвольное расстояние и строка, представляющая собой набор символов, для которых будет производиться дополнительное выравнивание. После того, как настройка произведена, печать текста производится с помощью процедуры, аналогичной TextOut.
Примечание: компонент написан под библиотеку KOL (1.55), но может быть легко портирован и под VCL, так как разницы в их работе в данном случае немного.
Пример работы компонента:
Две верхние строчки напечатаны с дополнительны выравниванием, две нижние - стандартными средствами. Очевидно, что видимые расстояния между символами стали выглядеть гораздо лучше.
| Объекты и процедуры модуля FineFont |
TFineFont- объект, в котором хранятся данные о межсимвольных расстояниях. Он же производит расчет расстояний и печать выравненного текста. Объект статический SetMinDistance- процедура установки межсимвольного расстояния. Может и должна вызываться перед инициализацией шрифта. AssignFont - настройка компонента на готовую канву. Шрифт канвы должен быть заранее проинициализирован. Внимание - шрифт канвы не должен быть растровым!
Надо заметить, что настройка компонента на новый шрифт происходит довольно медленно, несмотря на все оптимизации. Для символьного набора из 52 символов (английские заглавные + строчные буквы) инициализация идет 5 секунд на PII-233. Также очень сильно влияет и размер символов. Для ускорения работы следует как можно сильнее сжать символьный набор, исключить символы c вертикальными линиями по бокам - O, M, N, W и так далее.
Но есть и другой способ: AssignFontEx - настройка компонента с помощью сохраненных заранее параметров. Естественно, следует следить, чтобы настройки канвы в момент инициализации компонента совпадали с теми, которые вы сохранили когда-то с помощью процедуры SaveSettings. SaveSettings - сохраняет данные о символьном наборе и межсимвольных расстояниях в файл на диске. TextOut - печатает текст на заданной при вызове AssignFont канве. Аналог соответствующей функции TCanvas. Отличие в том, что эта функция не очищает фон перед печатью. В передаваемой строке могут содержаться символы, не входящие в символьный набор, заданный при вызове AssignFont. Они будут выводиться стандартным способом. CloseFont - освобождение занятой памяти. Процедура должна быть вызвана перед следующим вызовом AssignFont.
P.S.
Что касается развития компонента. Можно подумать о том, чтобы при настройке отсеивать несколько крайних точек символа, поскольку засечки на буквах в шрифтах типа Times "мешаются под ногами" и увеличивают видимое расстояние между символами.
Скачать пример: (35K) © Михаил Рудаков aka Miek, 11/2002
Доступ к реестру Win9x/ME без WinAPI
Думаю, каждый пользователь Windows хоть раз сталкивался с необходимостью чтения данных из неактивных файлов реестра. Существует, как минимум, 2 варианта решения данной задачи: воспользоваться стандартной утилитой regedit, которая может экспортировать и импортировать данные из файлов реестра. Второй вариант: использовать очень добротную и аккуратно написанную программу regview (для MSDOS), с отличным пользовательским интерфейсом ( - там же описание формата файлов реестра Win9x на русском).
К сожалению, для работы в пакетном режиме подходит лишь regedit. При этом, скорость оставляет желать лучшего...
Хочется поделиться с Вами, уважаемые, небольшим компонентом TRawRegistry для доступа к информации неактивных и активных файлов реестра формата Win9x/ME. Сразу оговорюсь: я не программист, и не собираюсь таковым быть, поэтому качество реализации оставляет желать лучшего (за неимением гербовой пишут на почтовой =)
TRawRegistry - реализует все методы и свойства класса TRegistry, необходимые для чтения ключей и значений параметров из реестра. На данный момент существуют, минимум, две основные проблемы: работа с бинарными данными и общая скорость доступа к файлам. Из-за использования динамических массивов (что легко исправимо), компилируется, начиная с D4.
В качестве примера прилагаю программу, использующую данный класс. Это аналог утилиты regedit, но без возможности записи какой бы то ни было информации в реестр.
Скачать архив (18K)
Искренне Ваш.
Илья Маляренко
Еще один комментарий к статье по поводу wsprintf
Предполагаемая история появления статьи "Использование функции wsprintf".
Будущий ю, это в данном случае не так важно, лишь бы она поддерживала переменное число параметров), пытается использовать в Delphi - а она не работает. Нет бы подумать, разобраться, почему в windows.pas функция объявлена так странно? Неужели в Borland при переводе заголовочных файлов допустили такую явную ошибку?
Но нет, сразу объявляется главный враг - это конечно Delphi и принятый в ней способ передачи параметров (кстати наиболее надежный, представьте что будет если процедура ожидает всего два параметра, а вы передадите три) и все дальнейшее обсуждение сводится к опусканию Delphi в контексте "как в C все просто, как в Delphi сложно и некрасиво" (уточняю, это мое личное впечатление от данной заметки и от некоторых статей обсуждаемого е же параметры, которые нужно подставить в исходную строку? Если подумать, то единственный разумный ответ: они уже должны быть в стеке. Теперь осталось еще совсем немного подумать и написать такую простенькую процедуру-обертку:
procedure cdecl_(Output: PChar; Format: PChar; args: array of integer); begin wsprintf(Output, Format) end; А теперь сравните данную процедуру (всего одна строчка) с теми монстрами, которые приведены в обсуждении статьи. И кто сказал что программа на Delphi не может быть красивой? Проверяем: var i: integer; mes: PChar; begin GetMem(mes, 255); i := 2; cdecl_(mes, PChar('%d+%d=%d'), [i, i, i + i]); ShowMessage(mes); FreeMem(mes) end;
Работает. Что неудивительно (достаточно посмотреть получившийся ассемблерный код во встроенном отладчике). Следовательно, единственный вывод, который можно сделать - недостаточное знакомство автора заметки с темой обсуждения. Не верите? - откройте статью "Open array parameters" во встроенной справке Delphi (5.0) и прочитайте: "When you pass an array as an open array value parameter, the compiler creates a local copy of the array within the routine's stack frame".
Еще раз о нечетком сравнении строк
По мотивам обсуждения статьи
Второй вариант поиска : (359 K)
Отличия от первого, по моим субъективным наблюдениям, в следующем: 1.Лучше находит похожие слова лежащие в одной плоскости Соха - Сноха - совпадение 88 при том что в первом алгоритме составило 66 при длине фразы = 3 2.Хуже находит похожие (даже идентичные), но перевернутые слова Тихий Дон - Дон Тихий - в первом способе совпадение 79 во втором 55 - очень существено.
Так что первый способ я рекомендовал для сравнения, например, полей двух баз данных. Второй способ, по моему убеждению, лучше использовать в поиске по словарю или в тех местах, где надо найти фразу.
Вообще-то, существуют еще, кроме этих, алгоритмы поиска. Я бы выделил SoundEx для сравнения, но у него есть свои недостатки — он языкозависим, но отлично подходит для сравнения английских фраз.
Если вас это заинтересует то могу прислать в оригинале (написан он на C), но перевести в Pascal для людей которых это заинтересует, не составит труда.
И, напоследок, предлагаю вам архив с примерами алгоритмов анализа строк. К сожалению страницы указанные в архиве, как начальные, где можно найти информацию, не работают - поэтому высылаю слепок с сайта. Скачать (185 К)
На данных страницах лежит очень много алгоритмов касающихся анализа строк, приведу список причем очень хорошо документированных и математически обоснованных.
3. ОБЗОР АЛГОРИТМОВ
Flexible Frame - механизм добавления
| й Перовский, дата публикации 02 января 2003г. |
Часто встречаются задачи, в которых все объекты могут отличаться друг от друга по структуре и алгоритмам. Описывать для каждого экземпляра отдельный тип неэффективно. Алгоритмические особенности отдельного экземпляра могут быть реализованы при помощи обработчиков событий. А как быть с полями? Для решения этой задачи предлагается механизм Flexible Frame (гибкий каркас). Что же стоит за таким парадоксальным названием. Просто у объекта, кроме стандартных полей, имеется список дополнительных именованных атрибутов различного типа.
В прилагаемых модулях список реализован на основе TStrings. Естественно, для использования в качестве атрибутов, все элементарные типы данных должны быть "упакованы" в соответствующие объекты.
Модуль uFFbase содержит описание следующих классов:
Модуль uFFform описывает FormFF - диалог для редактирования значений атрибутов простейших типов. Более сложные типы могут иметь собственные формы для редактирования, как это сделано в ObjectInspector-е.
Модуль uFFDic - пример расширения стандартного набора типов. TFFSlovar - класс атрибутов с перечислимым значением, хранит код строки в словаре и код словаря.
Описан список для регистрации словарей. TFFDicForm - диалог для редактирования значений.
Скачать (10K)
FloatSpinEdit. Компонент для ввода целых и дробных чисел
| Раздел Сокровищница |
В своих приложениях часто сталкиваюсь с необходимостью обеспечить удобный ввод дробных чисел. Для этого разработал компонент TFloatSpinEdit. Более чем уверен что подобных компонент разработано немало, но в силу лени и прочего, не искал оного в Internet, а написал своё.
Компонент FloatSpinEdit предназначен для ввода чисел целых и дробных чисел.
Вводить число можно как непосредственно с клавиатуры в поле ввода, так и увеличивая/уменьшая его значение при помощи компонента типа TUpDown или клавиш Up/Down. Кроме этого осуществляется контроль допустимого диапазона вводимого числа и корректности ввода. Существует так же возможность отображения суффикса (например "А/м"), после числа.
Компонент представляет собой контейнер (TWinControl), содержащий два компонента FEdit(TFloatEdit - потомок TEdit) и FUpDown(TUpDown)."
В компоненте введены следующие новые свойства, доступные как на стадии разработки, так и на стадии выполнения:
В определенных случаях будет так же проконтролировано символьное представление числа в свойстве Text, после чего свойство Text будет отформатировано в соответствии со свойствами Precision и Sufix:
Скачать (35 К)
Функции для работы с модулем
Все операции с формулами обрабатывает объект класса TDataEditor. У этого класса есть ряд методов для регистрации новых функций, типов, превода формул в сценарии и выполнения этих сценариев. Объект класса TDataEditor может хранить в себе одну формулу и один сценарий. Если Вы не собираетесь создавать новые функции, то можно просмотреть только описание функций преобразования строки в сценарий, думаю этого будет вполне достаточно, в противном случае я советую особое внимание уделить описанию методов регистрации новых функций и событию OnIntFunction.Функции для работы со строками
| Раздел Сокровищница |
Несколько функций для работы со строками. Они довольно простые, но может кому-нибудь пригодятся.
| Разбивка строки в список и слияние списка строк |
1. Разбивка строки на подстроки с учетом заданного символа(строки) разделителя
Str - исходная строка, R - символ(строка) разделитель, в результате получается список TStrings найденных строк. function StrToArrays(str, r: string; out Temp: TStrings): Boolean; var j: integer; begin IF temp <> Nil then Begin temp.Clear; while str <> '' do Begin j := Pos(r,str); if j=0 then j := Length(str) + 1; temp.Add(Copy(Str,1,j-1)); Delete(Str,1,j+length(r)-1); End; Result:=True; End else Result:=False; end;
2. Слияние списка строк в одну строку с вставкой символа(строки)-разделителя
function ArrayToStr(str: TStrings; r: string): string; var i: integer; begin Result:=''; IF str = nil Then Exit; for i:= 0 to Str.Count-1 do Result := Result+Str.Strings[i]+r; end;
Дополнителльно по этой же теме
Cмотрите реализацию функций TStrings.GetCommaText и TStrings.SetTextStr в модуле Classes
Коллективное творчество нескольких авторов
Функция копирования части строки
При работе со строками часто возникает необходимость копировать кусок строки от одного символа (или нескольких) до другого (других). Каждый раз использовать copy или delete нерационально, поэтому я написал небольшую функцию:
| function GetBetween(first,second,line:string):string; var posF,posS,i:integer; st:string; index:boolean; begin st:=''; posF:=pos(first,line)+length(first);//начало копирования posS:=pos(second,line);//конец копирования index:=true; i:=1; while (i<=length(line))and(index) do begin if (i>=posF)and(i |
Есть правда одно ограничение: если в строке встречается несколько одинаковых кусков и такой кусок выбран в роли first или second, то результат не всегда будет корректным.
Функция посылает окну строку синхронно через WM_COPYDATA
Функция посылает окну строку (с дополнительным любым числом) синхронно через WM_COPYDATA. Можно и другому приложению. function SendIPCString(TargetWnd, SourceWnd: THandle; dwData: integer; const S: string): integer; var CD: TCopyDataStruct; begin CD.dwData := dwData; CD.cbData := Length(S); if CD.cbData = 0 then CD.lpData := NIL else CD.lpData := @S[1]; Result := SendMessage(TargetWnd, WM_COPYDATA, SourceWnd, integer(@CD)); end;Алексей Еремеев
Функция приблизительного/нечеткого сравнения строк
| Недавно в поисках информации по интеллектуальным алгоритмам сравнения я нашел такой алгоритм — алгоритм сравнения (совпадения) двух строк, Так как он был написан на VBA, я под свои нужды переписал его на Delphi Уважаемые жители Королевства, я думаю данная функция пригодится тем, кто часто пишет функции поиска, особенно когда поиск приблизителен. То есть, например, в БД забито "Иванав Иван" - с ошибкой при наборе, а ищется "Иванов". Так вот, данный алгоритм может вам найти "Иванав" при вводе "Иванов",а также при "Иван Иванов" - даже наоборот с определенной степенью релевантности при сравнении. А используя сравнение в процентном отношении, вы можете производить поиск по неточным данным с более-менее степенью похожести. Еще раз повторяю, алгоритм не мой, я только его портировал на Delphi. А метод был предложен Владимиром Кива, за что ему огромное спасибо. |  |
Скачать проект (356 K)
Функция нечеткого сравнения строк БЕЗ УЧЕТА РЕГИСТРА
| //------------------------------------------------------------------------------ //MaxMatching - максимальная длина подстроки (достаточно 3-4) //strInputMatching - сравниваемая строка //strInputStandart - строка-образец // Сравнивание без учета регистра // if IndistinctMatching(4, "поисковая строка", "оригинальная строка - эталон") > 40 then ... Type TRetCount = packed record lngSubRows : Word; lngCountLike : Word; end; //------------------------------------------------------------------------------ function Matching(StrInputA: WideString; StrInputB: WideString; lngLen: Integer) : TRetCount; Var TempRet : TRetCount; PosStrB : Integer; PosStrA : Integer; StrA : WideString; StrB : WideString; StrTempA : WideString; StrTempB : WideString; begin StrA := String(StrInputA); StrB := String(StrInputB); For PosStrA:= 1 To Length(strA) - lngLen + 1 do begin StrTempA:= System.Copy(strA, PosStrA, lngLen); PosStrB:= 1; For PosStrB:= 1 To Length(strB) - lngLen + 1 do begin StrTempB:= System.Copy(strB, PosStrB, lngLen); If SysUtils.AnsiCompareText(StrTempA,StrTempB) = 0 Then begin Inc(TempRet.lngCountLike); break; end; end; Inc(TempRet.lngSubRows); end; // PosStrA Matching.lngCountLike:= TempRet.lngCountLike; Matching.lngSubRows := TempRet.lngSubRows; end; { function } //------------------------------------------------------------------------------ function IndistinctMatching(MaxMatching : Integer; strInputMatching: WideString; strInputStandart: WideString): Integer; Var gret : TRetCount; tret : TRetCount; lngCurLen: Integer ; //текущая длина подстроки begin //если не передан какой-либо параметр, то выход If (MaxMatching = 0) Or (Length(strInputMatching) = 0) Or (Length(strInputStandart) = 0) Then begin IndistinctMatching:= 0; exit; end; gret.lngCountLike:= 0; gret.lngSubRows := 0; // Цикл прохода по длине сравниваемой фразы For lngCurLen:= 1 To MaxMatching do begin //Сравниваем строку A со строкой B tret:= Matching(strInputMatching, strInputStandart, lngCurLen); gret.lngCountLike := gret.lngCountLike + tret.lngCountLike; gret.lngSubRows := gret.lngSubRows + tret.lngSubRows; //Сравниваем строку B со строкой A tret:= Matching(strInputStandart, strInputMatching, lngCurLen); gret.lngCountLike := gret.lngCountLike + tret.lngCountLike; gret.lngSubRows := gret.lngSubRows + tret.lngSubRows; end; If gret.lngSubRows = 0 Then begin IndistinctMatching:= 0; exit; end; IndistinctMatching:= Trunc((gret.lngCountLike / gret.lngSubRows) * 100); end; |
Кузан Дмитрий
Функция скрытия пиктограмм с рабочего стола
| Раздел Сокровищница |
Заметил в софтовых архивах, что появляються shareware программы с функцией скрытия пиктограмм с рабочего стола и эта возможность в некоторых декларируется как одна из самых "крутых". Стало обидно и смешно одновременно, поэтому набросал примерчик для тех кому интересно.
Чтобы скрыть пиктограммы, необходимо найти окно SysListView32, что делает код приведенный ниже. procedure TFrmProgman.FormCreate(Sender: TObject); begin FHandle := GetWindow(GetWindow(FindWindow('progman', nil), GW_CHILD), GW_CHILD); end; А здесь мы элементарно скрываем это окно или показываем. procedure TFrmProgman.btnHideClick(Sender: TObject); begin if TButton(Sender).Name = 'btnHide' then ShowWindow(FHandle, SW_HIDE) else ShowWindow(FHandle, SW_SHOW); end; При этом все функции рабочего стола активны - видна картинка, работает контекстное меню. Если же вы хотите и это убрать, тогда получите дескриптор окна progman.
(3K) — Пример для Дельфи 6, но код можно запустить под любой версией.
Исходники
Скачать модульСкачать программу тестирования скорости
Скачать практический пример
Использование буфера записей BDE
| Раздел Сокровищница |
Все идет к тому, что BDE в ближайшее время окончательно сдаст позиции компонентам прямого доступа к данным (IBX, dbExpress).
Но все наработанное с использованием BDE сразу не перепишешь и не выбросишь. Компоненты прямого доступа существенно расширяют возможности разработчика.
Недавно понадобилось напрямую работать с буфером записей запроса (TQuery), если бы можно было использовать IBQuery проблем бы с этим не возникло, но буфер записей BDE закрыт и просто до него не достучаться.
Задача стояла следующая: в БД (Interbase) при работе с достаточно большой таблицей появилась необходимость при навигации в ReadOnly DBGrid и нажатию короткой клавиши отмечать записи для отложенной печати (поле SOST := 1).
Данная задача решается несколькими способами:
Второй слишком долгий и ведет к увеличению сетевого трафика.
Третий метод возможно реализовать только с использованием IBX или ClientDataSet, что в этом конкретном случае не приемлемо.
Поэтому для решения задачи третьим методом пришлось искать где BDE хранит полученные от IB сервера данные, вот что из этого получилось: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Db, DBTables, Grids, DBGrids, BDE, Menus; type TForm1 = class(TForm) DataSource: TDataSource; Query: TQuery; DBGrid: TDBGrid; Database: TDatabase; SetFldQ: TQuery; PopupMenu: TPopupMenu; Sost1: TMenuItem; Sost0: TMenuItem; procedure FormCreate(Sender: TObject); procedure Sost1Click(Sender: TObject); procedure Sost0Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure SetSost(AValue: Integer); end; var Form1: TForm1; implementation {$R *.DFM} function GetBDERecBuff(ACursor: TQuery): Pointer;{cursor} Var P, P1: Pointer; CurNo, RecNo, RecSize: Integer; begin //Вызов этого метода синхронизирует положение курсора //DataSet и BDE ACursor.UpdateCursorPos; P := ACursor.Handle; Inc(PChar(P), $1E); P := Pointer(P^); Inc(PChar(P), $7E); P := Pointer(P^); Inc(PChar(P), $14); P := Pointer(P^); Inc(PChar(P), $36); P := Pointer(P^); // Получаем внутренний BDE-шный номер текущей записи P1 := P; Inc(PChar(P1), $A); Inc(PChar(P1), $2); RecNo := Integer(P1^) - 1; Inc(PChar(P), $4); P := Pointer(P^); // Получаем внутренний BDE-шный номер курсора P1 := P; Inc(PChar(P1), $11F); P1 := Pointer(P1^); CurNo := Word(P1^); // Получаем размер записи P1 := P; Inc(PChar(P1), $113); RecSize := Word(P1^); // Получаем указатель на массив где хранятся указатели на // буфера всех BDE курсоров Inc(PChar(P), $4); P := Pointer(P^); Inc(PChar(P), $68); P := Pointer(P^); // Выбираем из массива нужный нам указатель Inc(PChar(P), 4*(CurNo - 1)); P := Pointer(P^); // Получаем указатель на текущую запись Inc(PChar(P), RecNo * RecSize); Result := P; end; procedure PutFldToBDEBuf(ACursor: TQuery; AField: TField; pValue: Pointer); Var P: Pointer; begin // Получаем указатель на текущую запись P := GetBDERecBuff(ACursor); //складываем нужное значение в буфер BDE Check(DbiPutField(ACursor.Handle, AField.FieldNo, P, pValue)); //Вызов Resync для пересчета Calc-полей и немедленного отображений изменении на экране ACursor.Resync([]); end; procedure TForm1.FormCreate(Sender: TObject); begin Database.Open; Query.DataBaseName := Database.DatabaseName; SetFldQ.DataBaseName := Database.DatabaseName; DBGrid.PopupMenu := PopupMenu; Sost1.ShortCut := TextToShortCut('Ctrl+A'); Sost0.ShortCut := TextToShortCut('Ctrl+S'); Query.SQL.Text := 'SELECT * FROM AKODIF ORDER BY CODE'; Query.Open; SetFldQ.SQL.Text := 'UPDATE AKODIF SET SOST = :SOST WHERE CODE = :CODE'; SetFldQ.Prepare; end; procedure TForm1.SetSost(AValue: Integer); begin SetFldQ.ParamByName('SOST').AsInteger := AValue; SetFldQ.ParamByName('CODE').AsInteger := Query.FieldByName('CODE').AsInteger; SetFldQ.ExecSQL; PutFldToBDEBuf(Query, Query.FieldByName('SOST'), @AValue); end; procedure TForm1.Sost1Click(Sender: TObject); begin SetSost(1); end; procedure TForm1.Sost0Click(Sender: TObject); begin SetSost(0); end; end. Все описанное выше работает в Delphi 3, Delphi 4, Delphi 5. С BDE 5.01, idapi32.dll от 12.11.1999 размер 589 312. С другими версиями BDE скорее всего работать не будет!
Все, вышеописанное есть некий частный результат и интересует эта тема.
Использование функции wsprintf()
Данная заметка возможно, будет интересна для тех, кто программирует на Object Pascal с использованием только API-функций Windows.
Часто необходимо вывести (к примеру, даже в окошко с MB_OK) какое-то значение, будь то код ошибки типа HRESULT или результат работы какой-либо функции. Простейшее решение - использовать IntToStr() из модуля sysutils.pas. Однако в этом случае размер минимальной программы на Delphi увеличится с 16 до 41 кб, что лично меня очень неудовлетворяет. Хочется получить реальное преимущество в размерах, раз уж не используется VCL. Есть и другое объяснение - хотя мы и живём в эпоху быстрых процессоров и ёмких HDD, следить за качеством кода программ и его размерами обязывает культура программирования. В конце-концов это просто неразумно - ради одной функции тащить весь код из sysutils.pas и sysconst.pas. Складывается глупейшая ситуация - ради преобразования чисел в строку приходится мириться с тем, что к готовому exe-модулю подключаются многочисленные resourcestring и хлам в виде кучи ненужного кода.
Для некоторых преобразований можно использовать API-функцию wsprintf() из модуля windows.pas. Она позволяет произвести форматированную запись в буфер последовательности символов и значений аргументов. Вот как она описана: function wsprintf(Output: PChar; Format: PChar): Integer; stdcall; А вот так она описана в файле winuser.h: WINUSERAPI int WINAPIV wsprintfA(LPSTR, LPCSTR, ...); Как видно, осутствует третий параметр. Он подразумевает передачу значения произвольного типа - например, char* или int (при желании его можно даже опустить). Причина, по которой функция документирована неправильно - ограничение, накладываемое языком Object Pascal - он не позволяет передать в параметр функции значение произвольного типа (хотя, например, SizeOf() позволяет, но реализована она на системном уровне).
Я всё-таки нашёл способ приспособить wsprintf() для своих нужд. Выход - описать её самостоятельно в своей программе так:
function wsprintf( lpOut: LPSTR; lpFmt: LPCTSTR; p: Pointer ): Integer; stdcall; external 'user32.dll' name 'wsprintfA'; Теперь для вывода в буфер достаточно написать так: var szMessage: PChar; GetMem( szMessage, 256 ); // Определяем размер строки в памяти wsprintf( szMessage, 'Number %d', Pointer(899034)); MessageBox( 0, szMessage, 'Сообщение', MB_OK ); Предварительно надо выделить память для буфера, иначе форматирование не произойдёт.
Полную документацию по функции wsprintf() можно найти в справке Delphi. Добавлю, что для корректности можно приводить передаваемые значения не к типу Pointer, а к Pinteger - для типа Integer, PUINT - для целых беззнаковых и т. д.
Скачать demo-проект (0.67 K)
Смотрите также :
Использование команды RDTSC процессора Pentium для работы с малыми временными интервалам
| Раздел Сокровищница | нашел интересное использование команды RDTSC процессора Pentium для работы с малыми временными интервалами. Я думаю, что эта функция может найти широкое применение (в таймерах, управлении внешними устройствами, научных исследованиях). Пример прилагается (4K) Этот счетчик увеличивается на 1 на каждом такте CPU. Он стартует при включении компьютера или при нажатии кнопки RESET. Обычно функцию RDTSC используют при определении тактовой частоты процессора. Применяя программные ухищрения можно добиться измерения очень малых временных величин в реальном масштабе времени или применять для калибровки таймеров (предварительно определив при помощи этой же функции тактовую частоту процессора). Готовые примеры определения тактовой частоты при помощи функции RDTSC есть в интернете, например, на сайте Мастера Delphi" : function RDTSC: comp; var TimeStamp: record case byte of 1: (Whole: comp); 2: (Lo, Hi: Longint); end; begin asm db $0F; db $31; {$ifdef Cpu386} mov [TimeStamp.Lo], eax mov [TimeStamp.Hi], edx {$else} db D32 mov word ptr TimeStamp.Lo, AX db D32 mov word ptr TimeStamp.Hi, DX {$endif} end; Result := TimeStamp.Whole; end; |
Использование модуля
Использование SetRange
Метод procedure SetRange(const StartValues, EditValues: array of const);показывает не только записи, индексные поля которых лежат в диапазоне [StartValues..EndValues].
Пример: Пусть в наборе данных Table1 показываются все записи. Включим в структуру записинабора данных два поля: "Номер группы" и "Наименование товара". Пусть итекущий индекс построен по полю "Номер группы".
Напишем такой обработчик события: CheckBox1.Click:
| procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp: Integer; begin If CheckBox1.Checked then begin GrNumTmp := StrToInt(Edit1.Text); With Table1 do begin CancelRange; SetRange([GrMunTmp],[GrNumTmp]); end; end else Table1.CancelRange; end; |
В отфильтрованном наборе данных показываются только те записи, индексное поле текущего индекса у которых (в нашем случае "Номер группы") имеет значение, лежащее в заданном диапазоне. В данном случае диапазон определяется переменной GrNumTmp. Поэтому для GrNumTmp = 3 будут показаны записи, принадлежащие к группе 3.
Если бы мы захотели, чтобы в наборе данных фильтровались записи из нескольких групп, то нам следовало бы добавить в форму второй компонент Edit2, в котором вводился бы номер конечной группы, в то время как в Edit1 вводился бы номер начльной группы:
| procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp1, GrNumTmp2: Integer; begin If CheckBox.Checked then begin GrNumTmp1 := StrToInt(Edit1.Text); GrNumTmp2 := StrToInt(Edit2.Text); With Table1 do begin CancelRange; SetRange([GrNumTmp1],[GrNumTmp2]); end; end else Table1.CancelRange; end; |
Александр Мефодьев [29.01.2000] (Специально для "Королевства")
ICQ: 56666220
Использованные идеи и алгоритмы
Скачать проект (25K)
Смотрите также :
Используемые инструменты
Для копирования баз данных можно использовать различные инструменты. Я использую для этих целей специально разработанную программу копирования баз данных, под названием "Репликатор". Её можно скачать по адресуЧто же эта программа умеет?
Она умеет выполнять скрипты, копировать таблицы в нужной последовательности, отключать триггера, ключи, ограничения. А так же обходит ошибки вынося их текст в Лог и не обрывая соединение. А это нам и нужно для восстановления и перегенерации баз данных.
Изменение в ходе выполнения
| Раздел Сокровищница |
Сразу скажу, что эта статья - маленькая рекомендация тем, кто хочет реализовать возможность работы TWebBrowser в своей программе с настройками Proxy , которые отличаются от стандартных.
В один прекрасный день мне понадобилось в программе периодически менять Proxy и при этом пользоваться всем, что предоставляет IE. Лучший и единственный выбор - TwebBrowser. При близком знакомстве с ним стало понятно, что через Proxy он работать не может (вернее может, но берет настройки из "Свойств обозревателя"). Перспектива постоянно менять настройки реестра меня не прельщала . И как назло ни в одной крупной конференции не было даже упоминания о возможности настройки Proxy в ходе выполнения программы кроме изменения реестра (может плохо искал).
Перерыв Fido-архивы и конференции Инета накаткнулся на win-функцию UrlMkSetSessionOption. Вот к чему привели мои изыскания : .... uses ... urlmon, wininet ... .... var PIInfo : PInternetProxyInfo; ... New (PIInfo) ; // Изменение настроек ПРОКСИ PIInfo^.dwAccessType := INTERNET_OPEN_TYPE_PROXY ; // Тип доступа в интернет - через Proxy сервер PIInfo^.lpszProxy := PChar('some.proxy:someport'); // указать прокси напр. 195.43.67.33:8080 PIInfo^.lpszProxyBypass := PChar(''); // Список адресов, доступ к которым возможен минуя Proxy сервер UrlMkSetSessionOption(INTERNET_OPTION_PROXY, piinfo, SizeOf(Internet_Proxy_Info),0); .... Dispose (PIInfo) ; .... Вызывать функцию UrlMkSetSessionOption можно из любого места программы, причем любое количество раз и с разными настройками.
После вызова функции TWebBrowser будет работать через указанный прокси. Еще раз повторюсь, настройки касаются только текущей сессии (программы на момент выполнения ), общие настройки Windows не изменяются.
Андрей Попков
Дополнительно:
INTERNET_PROXY_INFO Structure Contains information that is supplied with the INTERNET_OPTION_PROXY value to get or set proxy information on a handle obtained from a call to the InternetOpen function. Syntax typedef struct { DWORD dwAccessType; LPCTSTR lpszProxy; LPCTSTR lpszProxyBypass; } INTERNET_PROXY_INFO, * LPINTERNET_PROXY_INFO; Members dwAccessType Unsigned long integer value that contains the access type. This can be one of the following values: INTERNET_OPEN_TYPE_DIRECT Internet accessed through a direct connection. INTERNET_OPEN_TYPE_PRECONFIG Applies only when setting proxy information. INTERNET_OPEN_TYPE_PROXY Internet accessed using a proxy. lpszProxy Address of a string value that contains the proxy server list. lpszProxyBypass Address of a string value that contains the proxy bypass list.
Это Unit1.pas
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons,StrEx,Math; type TForm1 = class(TForm) Edit1: TEdit; BitBtn1: TBitBtn; Label1: TLabel; Memo1: TMemo; Button1: TButton; Edit2: TEdit; Label2: TLabel; Button2: TButton; procedure BitBtn1Click(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Edit1Change(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; TProc=procedure; var Form1: TForm1; A:array of real; CS:array of Byte; DS:array of Real; Res,X,Y:real; proc:TProc; function preCalc(Ex:String):real; function Prepare(Ex:String):real; function SecindBracket(Ex:String;first:integer):Integer; implementation {$R *.DFM} // это про скобки... это просто и не заслуживает большого внимания. function SecindBracket(Ex:String;first:integer):Integer; var i,BrQ:integer; begin Result:=0; case Ex[first] of '(': begin i:=first+1; BrQ:=0; while (i<=length(Ex)) do begin if (BrQ=0) and (Ex[i]=')') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i+1; end; end; ')': begin i:=first-1; BrQ:=0; while (i>0) do begin if (BrQ=0) and (Ex[i]='(') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i-1; end; end; end; end; // а вот тут мы собственно и формируем процедуру function Prepare(Ex:String):real; begin SetLength(Ds,1); // вот это будет заголовок SetLength(CS,6); cs[0]:=$8b; cs[1]:=$05; cs[2]:=(integer(@ds) and $000000FF) shr 0; cs[3]:=(integer(@ds) and $0000FF00) shr 8; cs[4]:=(integer(@ds) and $00FF0000) shr 16; cs[5]:=(integer(@ds) and $FF000000) shr 24; // вот это - вычисление X:=1; //догадайтесь зачем :) preCalc(Ex); // а вот это - завершение SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$1D; cs[high(CS)-3]:=(integer(@res) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@res) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@res) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@res) and $FF000000) shr 24; SetLength(CS,high(CS)+2); // ну и не забудем про RET cs[high(CS)]:=$C3;// ret proc:=pointer(cs); end; // будем формировать код рассчета. function preCalc(Ex:String):real; var Sc,i,j:integer; s,s1:String; A,B:real; const Op: array [0..3] of char =('+','-','/','*'); begin s:=''; // да всегда инициализируйте переменные ваши for i:=1 to length(Ex) do if ex[i]<>' ' then s:=s+ex[i]; // чтобы под ногами не путались :) while SecindBracket(s,Length(s))=1 do s:=copy(s,2,Length(s)-2);// скобки if s='' then begin Result:=0; ShowMessage('Error !'); exit; end; val(s,Result,i); // это число ? а какое ? if i=0 then begin // ага это число. так и запишем Form1.Memo1.Lines.Add('fld '+FloatToStr(result)); SetLength(Ds,high(ds)+2); Ds[high(ds)]:=Result; SetLength(CS,high(CS)+4); cs[high(Cs)]:=high(ds)*8; cs[high(Cs)-1]:=$40; cs[high(Cs)-2]:=$DD; exit; end; if (s='x') or (s='X') then begin // опа, да это же Икс ! Form1.Memo1.Lines.Add('fld X'); SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$05; cs[high(CS)-3]:=(integer(@x) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@x) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@x) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@x) and $FF000000) shr 24; end; // это все еще выражение :( ох не кончились наши мучения i:=-1; j:=0; while j<=1 do Begin i:=length(s); Sc:=0; while i>0 do begin // ну скобки надо обойти if s[i]=')' then Inc(Sc); if s[i]='(' then Dec(Sc); if Sc<>0 then begin dec(i); continue; end; if (s[i]=Op[j*2]) then begin j:=j*2+10; break; end; if (s[i]=Op[j*2+1]) then begin j:=j*2+11; break; end; dec(i); end; inc(j); End; //('+','-','/','*'); // а вот и рекурсия - все что справа и слева от меня пусть обработает ... // ой да это же я:) Ну а я так уж и быть сформирую код операции в середине :) case j of 11: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FAddp St(1),st'); // cs //fAddP st(1),st // [DE C1] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C1; // вот такой код сформируем cs[high(Cs)-1]:=$DE; end; // далее - аналогично для каждой операции 12: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FSubP St(1),st'); //fSubP st(1),st // [DE E9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$E9; cs[high(Cs)-1]:=$DE; end; 13: begin try preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('fdivP st(1),st'); //fDivP st(1),st // [DE F9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$F9; cs[high(Cs)-1]:=$DE; except ShowMessage('Division by zero !... '); preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); exit; end; end; 14: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FMulp St(1),st'); //fMulP st(1),st // [DE C9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C9; cs[high(Cs)-1]:=$DE; end; end; end; // Вычисляй procedure TForm1.BitBtn1Click(Sender: TObject); begin x:=StrToFloat(Edit2.text); if (@proc<>nil) then proc; // Вычисляй Label1.caption:=FloatToStr( res ); end; // это всякие сервисные функции procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Clear; Prepare(Edit1.text); BitBtn1.Enabled:=true; end; procedure TForm1.Edit1Change(Sender: TObject); begin BitBtn1.Enabled:=false; end; procedure TForm1.FormCreate(Sender: TObject); begin Edit1.OnChange(self); end; // а это для того чтобы посмотреть какой за быстрый получился код procedure TForm1.Button2Click(Sender: TObject); //Speed test var t:TDateTime; i:integer; const N=$5000000; //количество повторений begin if @proc=nil then exit; t:=now; for i:=0 to N do begin x:=i; proc; x:=res; end; t:=now-t; Memo1.lines.add('work time for '+inttostr(N)+' repeats ='+TimeToStr(t)+' sec'); Memo1.lines.add('='+FloatToStr(t)+ ' days' ); end; end.Как появляются иконки в трее.
| Раздел Сокровищница | ан Минич, дата публикации 09 июля |
Иконку в трей помещают с помощью Shell_NotifyIconW. Интересено посмотреть на этот процесс с другой точки зрения.
Цитата с сайта delphi.mastak.ru:
Shell_NotifyIconW просто ищет окно с классом "Shell_TrayWnd" и посылает в него сообщение WM_COPYDATA. в качестве данных выступает простая структура TNIDMessage.
возвращаясь к топику: если создать свое окно с классом "Shell_TrayWnd" и обрабатывать входящие сообщения WM_COPYDATA, то можно написать полный аналог system tray! ...
(с) paul_shmakov
...чем и займемся.
В первую очередь немаловажное замечание: сообщение посылается только одному окну, то есть наше приложение должно грузится первым. Разные там explorer'ы и другие подобные будут мешать.
Шаг первый:
Создаем окно "Shell_TrayWnd"
| procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.WinClassName := 'Shell_TrayWnd'; end; |
Все. Окно класса "Shell_TrayWnd" имеем.
Шаг второй:
Ловим WM_COPYDATA
| procedure TFORM1.WMCOPYDATA(var Msg: Tmessage); var pcd: PCopyDataStruct; NID: PNotifyIconData; begin pcd := PCOPYDATASTRUCT(msg.lParam); if pcd^.dwData = 1 then begin NID := pointer(integer(pcd.lpData)+8); case integer(pointer(integer(pcd.lpData)+4)^) of NIM_ADD: Msg.Result := NewTrayIcon(NID); // добавить иконку NIM_DELETE: Msg.Result := DeleteTrayIcon(NID); // удалить иконку NIM_MODIFY: Msg.Result := ModifyTrayIcon(NID); // изменить иконку (или подсказку) end; exit; end; end; |
Обратите внимание на Msg.Result. Желательно чтобы NewTrayIcon, DeleteTrayIcon, ModifyTrayIcon возвращали Integer(True) или Integer(False) в зависимости от помещения/удаления иконки.
Некоторые приложения не проверяют этот результат, но если начнут проверять - то причины "глючного" поведения иконки того же AVP Monitor можно искать долго и безуспешно.
Шаг третий:
Поймали, и че с ним теперь делать?
А мы имеем очень интересную структуру -
Пример: PostMessage(NID.Wnd, NID.uCallBack, NID.uID, MOUSE_EVENT) где MOUSE_EVENT может принимать значения WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK и подобные для других кнопок мыши.
В случаях ошибки нужно информировать приложения про необходимость поместить иконки обратно. Для этого послужат такие действия:
| procedure TForm1.FormCreate(Sender: TObject); var WM_TASKBARCREATED: UINT; begin WM_TASKBARCREATED := RegisterWindowMessage('TaskbarCreated'); PostMessage(HWND_BROADCAST, WM_TASKBARCREATED, 0, 0); end; |
Скачать демо проект (9.8K)
И несколько слов о демо проекте.
ВНИМАНИЕ!!! Следуйте данным инструкциям только в том случае, если Вы ясно понимаете смысл действий!!!
Повторюсь: Shell_NotifyIconW сообщение посылает только одному окну. Поэтому чтобы увидеть результаты работы демопроекта, загружать его надо без или вместо explorer'а.
Первый вариант (для Win9x): Пример: файл %windir%\system.ini изменить следующим образом:
Найти строчку:
shell=explorer.exe Заменить на (предполагается что демопроект находится в C:\Demotray\ ) : ;shell=explorer.exe shell=c:\demotray\demotray.exe Перегрузите Windows
Для возврата explorer'a раскомментируйте первую строчку, закомментируйте или удалите вторую.
Второй вариант: Лично я использую Far для выгрузки Explorer.exe
выбираем EXPLORER.EXE->F8->OK
Используйте эти инструкции на свой страх и риск. Прочитайте их дважды. Внимательно изучите исходники. Трижды.
Инструкции по закрытию EXPLORER.EXE действительны для Win9x.
Если у Вас NT - разберитесь сами. Если не сможете разобратся - то за такие проекты Вам браться рановато.
Гревные ругательства "А у меня после ... ничего не работает!" не принимаются.
Благодарности:
Богдан Минич
Смотрите также:
Как создать свое окно предварительного просмотра QuickReport отчетов?
| Раздел Сокровищница |
Внятного и простого ответа куцая документация на компонент TQRPreview не дает. И, хотя ответ на этот вопрос действительно очень прост, мне все же пришлось потратить некоторое время на его поиски, результаты которых я и привожу.
Создайте пустую форму и поместите на нее объекты TQRPreview, TToolBar и TImageList. Свойство Align QRPreview установите в alClient. Добавьте на компонент TToolBar необходимые вам кнопки. В TImageList с помощью ImageList Editor поместите иконки для кнопок ToolBar`а (я использовал иконки от стандартного QuickReport окна предпросмотра выдранные в помощью Resource Explorer) и в свойство ToolBar.Images поместите имя созданного компонента TImageList.
Затем переходим к написанию обработчиков нажатий на кнопки. Основные используемые свойства : QRPreview.PageNumber - номер текущей просматриваемой страницы, QRPreview.Zoom - масштаб просмотра отчета и QRPreview.QRPrinter - объект принтера. Ниже показаны назначения кнопок и обработчики для них : * Печать отчета QRPreview.QRPrinter.Print; * Настройка принтера QRPreview.QRPrinter.PrintSetup; * Переход к первой странице QRPreview.PageNumber:=1; * Переход к предыдущей странице QRPreview.PageNumber:=QRPreview.PageNumber-1; * Переход к следующей странице QRPreview.PageNumber:=QRPreview.PageNumber+1; * Переход к последней странице QRPreview.PageNumber:=QRPreview.QRPrinter.PageCount; * Масштабирование отчета на 100% QRPreview.Zoom:=100; * Масштабирование отчета по ширине страницы QRPreview.ZoomToWidth; * Масштабирование отчета по целой странице QRPreview.ZoomToFit; Процедуры сохранения, загрузки отчета и подобные можно найти в исходниках QuickReport`а в файле qrprev.pas (почти все вышеперечисленные обработчики также взяты из этого файла).
Последнее что требуется сделать - написать такой обработчик события OnPreview просматриваемого отчета : frmPreview.QRPreview.QRPrinter:=TQRPrinter(Sender); //frmPreview - форма frmPreview.Show; // окна предпросмотра Видно, что окно предпросмотра не содержит ссылок на конкретный компонент TQuickRep и очевидно что его можно использовать в различных отчетах и программах. Разумеется всплывающие подсказки на кнопках и прочие красивости вставляются по вкусу.
В обработчик закрытия окна нужно записать следующие строки : QRPreview.QRPrinter.ShowingPreview:=false; QRPreview.QRPrinter.Free;
PS. Замечания и исправления принимаются по адресу shadowj@yandex.ru
Алексей Трунтов
Специально для
Как все это работает:
Компилятор он и есть компилятор. Сначала выражение надо скомпилировать. Делается это с помощью функцииfunction Prepare(Ex:String):real; которая вызывает function preCalc(Ex:String):real;формирующую код, вычисляющий заданное выражение. Как можно догадаться, Ex - это строка, содержащая математическое выражение. Функция preCalc рекурсивна и распознавая полученную математику, попутно формируя исполняемый код. Она имеет мало проверок на корректность и нет нужды вводить туда мусор и радоваться, когда увидите что все повисло. Помните правило GIGO (Garbage in Garbage Out). Не надо также ставить 0 под знак деления. Но это уже не моя ошибка :)))
ВНИМАНИЕ:
ограничение на глубина рекурсии: полученый код не должен помещать в стек более 8 значений.Снятие этого ограничения опять же лишь вопрос практической реализации.
Для понятности формируемый код представляется в ближайшем Memo. Функция возвращает: а фиг его знает что она возвращает :) лучше не обращайте внимания :)
Скомпилировали? Теперь можно и запускать:
При компиляции мы сформировали процедуру с красноречивым названием: proc:TProc; где type TProc=procedure; пример запуска можно найти в procedure TForm1.BitBtn1Click(Sender: TObject); Также встречаются процедуры и функции: function SecindBracket(Ex:String;first:integer):Integer; вот уж и не помню, отчего появилось такое красивое название (скорее всего от очепятки), но все это призвано обработать скобки в выражении , procedure TForm1.BitBtn1Click(Sender: TObject); // Вычисляйзапускает вычисление, а также procedure TForm1.Button2Click(Sender: TObject); //Speed testдля того чтобы посмотреть какой за быстрый получился код.
К сему прилагается слегка комментированный исходный код. Вряд ли кому нужны комментарии типа: I:=0; // обнуляем счетчик а по структуре программы там комментариев хватает.
Ну вот и все... Буду рад если вам это пригодиться. Если какие пожелания - пишите. Конструктивная критика - пишите. Неконструктивная критика - тоже пишите - у меня файлы удаляются без помещения в корзину.
Как выставить приоритет любому процессу
В качестве параметров необходимо передать _имя процесса_ (то, которое в диспетчере задач) и приоритет.
Не забудьте также подключить модуль TLHelp32.
| procedure SetPriority(Name: String; Priority: Integer); var Handler: THandle; Data: TProcessEntry32; Finded: boolean; Res: boolean; ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; function ReturnName: String; var I : byte; Names: string; begin names:=''; i:=0; while data.szExeFile[i] <> '' do begin names:=names+data.szExeFile[i]; inc(i); end; ReturnName:=names; end; procedure TryIt; begin if AnsiUpperCase(ReturnName)=AnsiUpperCase(Name) then begin ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, true, data.th32ProcessID); Finded:=true; if ProcessHandle=0 then begin RaiseLastWin32Error; exit; end; case Priority of 0: Res:=true; 1: Res:=SetPriorityClass(ProcessHandle, IDLE_PRIORITY_CLASS); 2: Res:=SetPriorityClass(ProcessHandle, NORMAL_PRIORITY_CLASS); 3: Res:=SetPriorityClass(ProcessHandle, HIGH_PRIORITY_CLASS); 4: Res:=SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); end; if not Res then RaiseLastWin32Error; end; end; begin Finded:=false; Handler:= CreateToolHelp32SnapShot(TH32CS_SNAPALL,0); if process32first(handler,data) then begin TryIt; while process32next(handler,data) do TryIt end; if not Finded then ShowMessage('Cannot find'); end; |
Как заставить работать ActionList в формах, импортируемых из DLL
При использовании форм, импортируемых из DLL, вы столкнетесь с проблемой что ActionList работать не будет до тех пор, пока вы не активизируете его обновление самостоятельно. А следовательно, обновление всех компонентов управления работать не будет.
Класс для чтения/записи потока с преобразованием информации "на лету".
| й Перовский, дата публикации 18 ноября 2003г. |
Мне пришлось столкнуться с проблемой записи информации в шифрованный файл. Причем в прототипе использовалась запись иерархии объектов в FileStream при помощи функций Load и Store. Чтобы не переделывать объекты и методы сохранения/восстановления, я создал класс TСryptoStream наследник TStream, предназначенный для блочного шифрования информации. Понятно, что сам метод шифрования может быть произвольным. Более того, это может быть совсем не шифрование, а, например, перекодировка, подсчет статистики и т.д.
Работа с TCryptoStream аналогична работе с TFileStream - при создании объекта указывается режим записи или чтения. Для преобразования блоков используется внешняя функция.
| const csmOpenRead =0; {либо чтение, либо запись} csmOpenWrite =1; {только последовательный доступ} type Tcsm = csmOpenRead .. csmOpenWrite;{csm- CryptoStreamMode - режим работы} {Функция блочного преобразования должна быть этого типа} TTransform=procedure ( Buffer:pointer; Count: Longint); {Описание класса TCryptoStream} TCryptoStream=class (TStream) private fMode:Tcsm; {либо чтение, либо запись} FS:TStream; {обрабатываемый поток} FTransform:TTransform;{Функция блочного преобразования} Data:pointer; {Указатель на блок для преобразования} L:integer; {Размер блока преобразования} Ost:integer; {Текущее свободное место в блоке} public constructor Create(S:TStream;al:integer; aTransform: TTransform;Mode: Tcsm); destructor destroy;override; function Read(var Buffer; Count: Longint): Longint;override; function Write(const Buffer; Count: Longint): Longint; override; end; |
В прилагаемых файлах, кроме собственно модуля uCryptoStream, содержится проект, демонстрирующий использование TСryptoStream для шифрования потока простейшим методом (XOR с заданным значением).
Скачать (4.5K)
Класс для реализации списка Variant'ов на основе TCollection
Класс реализует коллекцию элементов типа Variant, которые могут интерпретироваться как Integer, String или Currency.Динамический список этих элементов может быть именованным, где каждому элементу присваивается имя. Это условие по умолчанию не обрабатывается, так что с этим классом можно работать просто как с динамическим списком величин типа Variant.
Довольно удобно.
Можно искать в списке по значению (IndexOF), по имени (GetValueFromName), удалять из списка.
Функция JoinList возвращает строку из символьного представления всех элементов списка разделенных заданным сепаратором.
Скачать файл (2K)
unit ListUtils; interface Uses Classes , SysUtils; Type TListsItem = class(TCollectionItem) Private FValue : Variant; FName : String; Protected Function GetAsInteger : LongInt; Procedure SetAsInteger(AValue : LongInt ); Function GetAsString : String; Procedure SetAsString(AValue : String ); Function GetAsCurrency : Currency; Procedure SetAsCurrency(AValue : Currency ); Public procedure AssignTo( Dest: TPersistent ); override; property Value : Variant read FValue write FValue; property Name : String read FName write FName; property AsInteger : LongInt read GetAsInteger write SetAsInteger; property AsString : String read GetAsString write SetAsString; property AsCurrency : Currency read GetAsCurrency write SetAsCurrency; End; TCollectionListItemClass = class (TListsItem); TLists = class (TCollection) private function GetListItem(Index : Integer) : TListsItem; Public Constructor Create(ItemClass: TCollectionItemClass); Function AddItem( Value : Variant; AName : String ='' ) : TListsItem; Procedure FillFromArray(ArValue : array of Variant); Procedure FillFromNamedArray(ArValue , ArName : array of Variant ); Function IndexOf( Value : Variant ) : Integer; Function JoinList( Separator : String = ',') : String; Function GetFromName(AName : String ) : TListsItem; Function GetValueFromName(AName : String; DefaultValue : Variant ) : Variant; Procedure DeleteFromValue( Value : Variant; All : Boolean = FALSE); Procedure DeleteFromName(AName : String ); Property AnItems[Index : Integer] : TListsItem read GetListItem; default; End; implementation //---------------------------------------------------------------------------------------- // TLists //---------------------------------------------------------------------------------------- Constructor TLists.Create(ItemClass: TCollectionItemClass); Begin Inherited Create(ItemClass); End; //---------------------------------------------------------------------------------------- function TLists.GetListItem(Index : Integer) : TListsItem; Begin Result:=TListsItem(Items[Index]); End; //---------------------------------------------------------------------------------------- function TLists.AddItem(Value : Variant; AName : String = '') : TListsItem; Begin Result:=TListsItem(Self.Add); Result.FValue:=Value; Result.FName:=AName; End; //---------------------------------------------------------------------------------------- function TLists.IndexOf(Value : Variant): Integer; begin Result := 0; while (Result < Count) and ( AnItems[Result].Value <> Value) do Inc(Result); IF Result = Count then Result := -1; end; //---------------------------------------------------------------------------------------- Function TLists.JoinList( Separator : String = ',') : String; Var i : Integer; Begin Result:=''; IF Count > 0 Then Begin For i:=0 To Count-1 Do Result:= Result + AnItems[i].AsString + Separator; Result:=Copy(Result , 1 , Length(Result)-1 ); End; End; //---------------------------------------------------------------------------------------- Procedure TLists.DeleteFromValue( Value : Variant; All : Boolean = FALSE); Var i : Integer; Begin i:=IndexOf(Value); IF i >= 0 Then Delete(i); End; //---------------------------------------------------------------------------------------- Procedure TLists.DeleteFromName(AName : String ); Var i : Integer; AItem : TListsItem; Begin AItem:=GetFromName(AName); IF AItem <> nil Then Delete(AItem.Index); End; //---------------------------------------------------------------------------------------- Function TLists.GetFromName(AName : String ) : TListsItem; Var i : Integer; Begin Result:=nil; For i:=0 To Count-1 Do IF CompareText(AnItems[i].FName , AName) = 0 Then Begin Result:=AnItems[i]; Exit; End; End; //---------------------------------------------------------------------------------------- Function TLists.GetValueFromName(AName : String; DefaultValue : Variant ) : Variant; Begin Result:=DefaultValue; IF GetFromName(AName) <> nil Then Result:= GetFromName(AName).Value; End; //---------------------------------------------------------------------------------------- Procedure TLists.FillFromArray(ArValue : array of Variant); Var i : Integer; Begin Clear; For i:=Low(ArValue) TO High(ArValue) Do AddItem(ArValue[i]); End; //---------------------------------------------------------------------------------------- Procedure TLists.FillFromNamedArray(ArValue , ArName : array of Variant ); Var i , No : Integer; Begin FillFromArray(ArValue); No:=High(ArName); IF No > High(ArValue) Then No:=High(ArValue); For i:=Low(ArName) TO No Do AnItems[i].FName:=ArName[i] ; End; //---------------------------------------------------------------------------------------- //**************************************************************************************** //---------------------------------------------------------------------------------------- // TListItem //---------------------------------------------------------------------------------------- procedure TListsItem.AssignTo( Dest: TPersistent ); Begin IF Dest Is TListsItem Then Begin TListsItem(Dest).FValue:=FValue; TListsItem(Dest).FName:=FName; End Else inherited; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsInteger : LongInt; Begin if TVarData(FValue).VType <> varNull then Result := TVarData(FValue).vInteger else Result := 0; End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsInteger(AValue : LongInt ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsString : String; Begin Result:=VarToStr(FValue); End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsString(AValue : String ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsCurrency : Currency; Begin if TVarData(FValue).VType <> varNull then Result := TVarData(FValue).vCurrency else Result := 0; End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsCurrency(AValue : Currency ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- end.
Класс TRySharedSream.
unit RySharedStream; interface uses SysUtils, Windows, Classes, RySharedMem; {$IFDEF VER120} {$DEFINE D5} {$ENDIF} {$IFDEF VER130} {$DEFINE D5} {$ENDIF} {$IFDEF VER140} {$DEFINE D6} {$ENDIF} type { TRyPageList } TRyPageList = class(TList) protected function Get(Index: Integer): TRySharedMem; procedure (Index: Integer; Item: TRySharedMem); public property Items[Index: Integer]: TRySharedMem read Get write Put; default; end; { TRySharedStream } TRySharedStream = class(TStream) { Для совместимости с TStream } private FSize : Longint; { Реальный размер записанных данных } FPosition : Longint; FPages : TRyPageList; protected function NewPage: TRySharedMem; public constructor Create; destructor Destroy; override; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure (NewSize: Longint); override; procedure (Stream: TStream); procedure (const FileName: string); procedure (Stream: TStream); procedure (const FileName: string); public end; implementation uses RyActiveX; {resourcestring CouldNotMapViewOfFile = 'Could not map view of file.';} { TRySharedStream } { * Класс TRySharedStream можно рассматривать как альтернативу временным файлам (т.е. как замену TFileStream). Преимущество : а. Данные никто не сможет просмотреть. б. Страницы, зарезервированные под данные, автомотически освобождаются после уничтожения создавшего ее TRySharedStream'а. * Класс TRySharedStream можно рассматривать как альтернативу TMemoryStream. Преимущество : а. Не надо опасаться нехватки памяти при большом объеме записываемых данных. [случай когда физически нехватает места на диске здесь не рассматривается]. Известные проблемы: На данный момент таких не выявлено. Но есть одно НО. Я не знаю как поведет себя TRySharedStream в результате нехватки места а. на диске б. в файле подкачки (т.е. в системе с ограниченным размером файла подкачки). } const PageSize = 1024000; { размер страницы } constructor TRySharedStream.Create; begin FPosition := 0; { Позиция "курсора" } FSize := 0; { Размер данных } FPages := TRyPageList.Create; FPages.Add(NewPage); end; destructor TRySharedStream.Destroy; begin with FPages do while Count > 0 do begin Items[Count - 1].Free; Delete(Count-1); end; FPages.Free; inherited; end; function TRySharedStream.NewPage: TRySharedMem; begin Result := TRySharedMem.Create(RyActiveX.GUIDToString(RyActiveX.GetGUID), 0, PageSize) { |} {Я знаю что можно не именовать страницу __|} {но оказалось не всегда Win98 правильно создает новую} {неименнованную страницу. а другого способа получения} {уникальной строки я не знаю. } {если у кого-то будут идеи по этому поводу - милости просим.} end; function TRySharedStream.Read(var Buffer; Count: Longint): Longint; var FPos, BPos, FPageNo: Integer; ACount, FCount : Longint; Buf: PChar; begin Buf := @Buffer; ACount := 0; if Count > 0 then begin FCount := FSize - FPosition; {максимальное кол-во, которое можно прочитать} if FCount > 0 then begin if FCount > Count then FCount := Count; {если нам нужно прочитать меньше чем можем} ACount := FCount; {запоминаем сколько надо} FPageNo := FPosition div PageSize; {т.к. у нас многостраничный stream, то находим с какой страницы начать читать} BPos := 0; FPos := FPosition - (PageSize * FPageNo); {с какой позиции на странице читаем} while FCount > 0 do begin if FCount > (PageSize - FPos) then Count := PageSize - FPos else Count := FCount; {определяем сколько можно прочитать со страницы} Move(PChar(FPages.Items[FPageNo].Memory)[FPos], Buf[BPos], Count); {считаваем инфо. в буффер} Inc(FPageNo); {переходим на следующую страницу} Dec(FCount, Count); Inc(BPos, Count); FPos := 0; end; Inc(FPosition, ACount); end end; Result := ACount; end; function TRySharedStream.Write(const Buffer; Count: Longint): Longint; var FPos, BPos, FPageNo: Integer; ASize, ACount, FCount : Longint; Buf: PChar; begin { Функция аналогичная TStream.Write(). Все пояснения по работе с ней см. в help'e. } Buf := @Buffer; if Count > 0 then begin ASize := FPosition + Count; {определяем сколько места нужно для данных} if FSize < ASize then Size := ASize; {если больше чем было, то увеличиваем размер стрима} FCount := Count; {запоминаем сколько надо записать} FPageNo := FPosition div PageSize; {определяем с какой страницы начинаем писать} BPos := 0; FPos := FPosition - (PageSize * FPageNo); {вычисляем позицию на странице} while FCount > 0 do {пока все не напишем ни куда не уходим} begin if FCount > (PageSize - FPos) then ACount := PageSize - FPos else ACount := FCount; Move(Buf[BPos], PChar(FPages.Items[FPageNo].Memory)[FPos], ACount); {пишем сколько влезает до конца страницы} Inc(FPageNo); {переходим на следующую страницу} Dec(FCount, ACount); {уменьшаем кол-во незаписанных на кол-во записанных} Inc(BPos, ACount); FPos := 0; end; FPosition := ASize; end; Result := Count; end; function TRySharedStream.Seek(Offset: Longint; Origin: Word): Longint; begin { Функция аналогичная TStream.Seek(). Все пояснения по работе с ней см. в help'e. } case Origin of soFromBeginning : FPosition := Offset; soFromCurrent : Inc(FPosition, Offset); soFromEnd : FPosition := FSize - Offset; end; if FPosition > FSize then FPosition := FSize else if FPosition < 0 then FPosition := 0; Result := FPosition; end; procedure TRySharedStream.SetSize(NewSize: Longint); var Sz: Longint; begin { Функция аналогичная TStream.SetSize(). Все пояснения по работе с ней см. в help'e. } inherited SetSize(NewSize); if NewSize > (PageSize * FPages.Count) then { Если размер необходимый для записи данных больше размера выделенного под наш stream, то мы должны увеличить размер stream'a} begin { ...но FileMapping не поддерживает изменения размеров "страницы", что не очень удобно, поэтому приходится выкручиваться. } Sz := NewSize div (PageSize * FPages.Count); { думаем сколько нужно досоздать страниц под данные } while Sz > 0 do {создаем страницы} begin FPages.Add(NewPage); Dec(Sz); end; end; FSize := NewSize; { Запоминаем размер данных } if FPosition > FSize then FPosition := FSize; end; procedure TRySharedStream.LoadFromFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream) finally Stream.Free end end; procedure TRySharedStream.LoadFromStream(Stream: TStream); begin CopyFrom(Stream, 0); end; procedure TRySharedStream.SaveToFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream) finally Stream.Free end end; procedure TRySharedStream.SaveToStream(Stream: TStream); begin Stream.CopyFrom(Self, 0); end; { TRyPageList } function TRyPageList.Get(Index: Integer): TRySharedMem; begin Result := TRySharedMem(inherited Get(Index)) end; procedure TRyPageList.Put(Index: Integer; Item: TRySharedMem); begin inherited Put(Index, Item) end; end.Алексей Румянцев
Специально для
Прилагается демонстрационный пример использования TRySharedStream : (13 K)
Класс TRyTimer.
| Раздел Сокровищница |
Описание:
Обертка для стандартного Windows'таймера. Аналог TTimer.
Отличия от TTimer'а:
не тянет за сабой TComponent, uses Forms, Application
Скачать Демо_Архив (4 K) 22.04.02
Алексей Румянцев
.
Специально для
Класс TSharedSream.
unit SharedStream; interface uses SysUtils, Windows, Classes, Consts; type { TSharedStream } TSharedStream = class(TStream) { Для совместимости с TStream } private FMemory : Pointer; { Указатель на данные } FSize : Longint; { Реальный размер записанных данных } FPageSize : Longint; { Размер выделенной "страницы" под данные } FPosition : Longint; { Текущая позиция "курсора" на "странице" } protected public constructor Create; destructor Destroy; override; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Integer): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure SetSize(NewSize: Longint); override; procedure LoadFromStream(Stream: TStream); procedure LoadFromFile(const FileName: string); procedure SaveToStream(Stream: TStream); procedure SaveToFile(const FileName: string); public property Memory: Pointer read FMemory; end; const SwapHandle = $FFFFFFFF; { Handle файла подкачки } implementation resourcestring CouldNotMapViewOfFile = 'Could not map view of file.'; { TSharedStream } { * TSharedStream работает правильно только с файлом подкачки, с обычным файлом проще и надежнее работать TFileStream'ом. * Для тех кто знаком с File Mapping Functions'ами : Класс TSharedStream не может использоваться для синхронизации(разделения) данных среди различных процессов(программ/приложений). [пояснения в конструкторе] * Класс TSharedStream можно рассматривать как альтернативу временным файлам (т.е. как замену TFileStream). Преимущество : а. Данные никто не сможет просмотреть. б. Страница, зарезервированная под данные, автомотически освобождается после уничтожения создавшего ее TSharedStream'а. * Класс TSharedStream можно рассматривать как альтернативу TMemoryStream. Преимущество : а. Не надо опасаться нехватки памяти при большом объеме записываемых данных. [случай когда физически нехватает места на диске здесь не рассматривается]. Известные проблемы: На данный момент таких не выявлено. Но есть одно НО. Я не знаю как поведет себя TSharedStream в результате нехватки места а. на диске б. в файле подкачки (т.е. в системе с ограниченным размером файла подкачки). } constructor TSharedStream.Create; const Sz = 1024000; { Первоначальный размер страницы }{ взят с потолка } var SHandle : THandle; begin FPosition := 0; { Позиция "курсора" } FSize := 0; { Размер данных } FPageSize := Sz; { Выделенная область под данные } { Создаем дескриптор объекта отображения данных. //эта формулировка взята из книги Проще сказать - создаем страницу под данные. //разрешите, я здесь и далее //буду употреблять более протые //информационные вставки. Все подробности по CreateFileMapping в Help'e. } SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, Sz, nil ); { Создаем "страницу"___| | | |} { Handle файла подкачки ______| | |} { Задаем размер "страницы"[Sz]. Не может быть = нулю______________| |} { Имя "страницы" должно быть нулевым[nil]_____________________________| иначе Вам в последствии не удастся изменить размер "страницы". (Подробнее см. в TSharedStream.SetSize). * Для тех кто знаком с File Mapping Functions'ами : раз страница осталась неименованной, то Вам не удастся использовать ее для синхронизации(разделения) данных среди различных процессов(программ/приложений). [остальных недолжно волновать это отступление] } if SHandle = 0 then raise Exception.Create(CouldNotMapViewOfFile); { ошибка - неудалось создать объект отображения[т.е. "страница" не создана и указатель на нее = 0]. Это может быть: Если Вы что-либо изменяли в конструкторе - a. Из-за ошибки в параметрах, передоваемых функции CreateFileMapping б. Если Sz FMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, Sz); { Получаем указатель на данные } if FMemory = nil then raise Exception.Create(CouldNotMapViewOfFile); { Виндус наверно может взбрыкнуться и вернуть nil, но я таких ситуаций не встречал. естественно если на предыдущих дейсвиях не возникало ошибок и если переданы корректные параметры для функции MapViewOfFile() } CloseHandle(SHandle); end; destructor TSharedStream.Destroy; begin UnmapViewOfFile(FMemory); { закрываем страницу. если у Вас не фиксированный размер файла подкачки, то через пару минут вы должны увидеть уменьшение его размера. } inherited Destroy; end; function TSharedStream.Read(var Buffer; Count: Longint): Longint; begin { Функция аналогичная TStream.Read(). Все пояснения по работе с ней см. в help'e. } if Count > 0 then begin Result := FSize - FPosition; if Result > 0 then begin if Result > Count then Result := Count; Move((PChar(FMemory) + FPosition)^, Buffer, Result); Inc(FPosition, Result); end end else Result := 0 end; function TSharedStream.Write(const Buffer; Count: Integer): Longint; var I : Integer; begin { Функция аналогичная TStream.Write(). Все пояснения по работе с ней см. в help'e. } if Count > 0 then begin I := FPosition + Count; if FSize < I then Size := I; System.Move(Buffer, (PChar(FMemory) + FPosition)^, Count); FPosition := I; Result := Count; end else Result := 0 end; function TSharedStream.Seek(Offset: Integer; Origin: Word): Longint; begin { Функция аналогичная TStream.Seek(). Все пояснения по работе с ней см. в help'e. } case Origin of soFromBeginning : FPosition := Offset; soFromCurrent : Inc(FPosition, Offset); soFromEnd : FPosition := FSize - Offset; end; if FPosition > FSize then FPosition := FSize else if FPosition < 0 then FPosition := 0; Result := FPosition; end; procedure TSharedStream.SetSize(NewSize: Integer); const Sz = 1024000; var NewSz : Integer; SHandle : THandle; SMemory : Pointer; begin { Функция аналогичная TStream.SetSize(). Все пояснения по работе с ней см. в help'e. } inherited SetSize(NewSize); if NewSize > FPageSize then { Если размер необходимый для записи данных больше размера выделенного под "страницу", то мы должны увеличить размер "страницы", но... } begin { ...но FileMapping не поддерживает изменения размеров "страницы", что не очень удобно, поэтому приходится выкручиваться. } NewSz := NewSize + Sz; { задаем размер страницы + 1Meтр[чтобы уменьшить работу со страницами]. } { Создаем новую страницу }{ возможные ошибки создания страницы описаны в конструкторе TSharedStream. } SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, NewSz, nil ); if SHandle = 0 then raise Exception.Create(CouldNotMapViewOfFile); SMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, NewSz); if SMemory = nil then raise Exception.Create(CouldNotMapViewOfFile); CloseHandle(SHandle); Move(FMemory^, SMemory^, FSize); { Перемещаем данные из старой "страницы" в новую } UnmapViewOfFile(FMemory); { Закрываем старую "страницу" } FMemory := SMemory; FPageSize := NewSz; { Запоминаем размер "страницы" } end; FSize := NewSize; { Запоминаем размер данных } if FPosition > FSize then FPosition := FSize; end; procedure TSharedStream.LoadFromFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream) finally Stream.Free end end; procedure TSharedStream.LoadFromStream(Stream: TStream); var Count: Longint; begin Stream.Position := 0; Count := Stream.Size; SetSize(Count); if Count > 0 then Stream.Read(FMemory^, Count); end; procedure TSharedStream.SaveToFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream) finally Stream.Free end end; procedure TSharedStream.SaveToStream(Stream: TStream); begin Stream.Write(FMemory^, FSize); end; end.Алексей Румянцев
Специально для
Прилагается демонстрационный пример использования TSharedStream : (6.2K)
Комментарий к статье по поводу wsprintf
Сама по себе статья вызывает мало интереса, кроме того, что поднята интересная проблема - вызов с-шной функции с переменным числом параметров. В ответах с использованием массивов вообще, IMHO, ошибка - на стек попадет адрес массива, а в с это совсем не то. Но решение проблемы существует, правда надо ручками повозиться со стеком. Приводимая ниже функция на скорую руку переделывается из работающей в реальном проекте похожего буфера с-паскаль, но там функция в dll имеет тип вызова cdecl и другие обязательные параметры, в связи с чем возможны "опечатки" /*------------------------------------------------------------------*/ // Пишем функцию-переходник, маскируя с-шные "..." паскалевским // array of const function sprintf(out, fmt: Pchar; args: array of const): Integer; var I: Integer; BufPtr: Pchar; S: String; buf: array[0..1024] of char; begin BufPtr := buf; // Формируем буффер параметров. Можно, конечно, и прямо на стеке, // но головной боли слишком много - проще так for I:=low(Par) to High(Par) do case Par[I].VType of vtInteger : // Здесь все просто - 4 байта на стек begin Integer(Pointer(BufPtr)^) := Par[I].VInteger; Inc(BufPtr,4); end; vtExtended: // Здесь хуже - слова надо местами поменять :-(( begin Integer(Pointer(BufPtr)^) := Integer(Pointer(Pchar(Par[I].VExtended)+4)^); Inc(BufPtr,4); Integer(Pointer(BufPtr)^) := Integer(Pointer(Par[I].VExtended)^); Inc(BufPtr,4); end; vtPChar : // Здесь тоже все хорошо - 4 байта begin Pointer(Pointer(BufPtr)^) := Par[I].VPchar; Inc(BufPtr,4); end; vtString, vtAnsiString : // А здесь во избежание чудес надо // копию строки снять begin if Par[I].VType = vtString then S := Par[I].VString^ else S:= string(Par[I].VAnsiString); Pointer(Pointer(BufPtr)^ := StrPCopy(StrAlloc(Length(S)+1), S); Inc(BufPtr,4); end; end; // Поддержку других типов доделывать самостоятельно, // вооружившись толковым пособием по с и ассемблеру I := (BufPtr - buf) div 4; // Сколько раз на стек слово положить asm push dword ptr [out] push dword ptr [fmt] mov ecx, dword ptr [i] mov eax, dword ptr [buf] // stdcall - параметры в прямом // порядке @@1: push dword ptr [eax] add eax, 4 loop @@1 call [wsprintf] mov dword ptr [Result], eax // Сохранить результат mov eax, dword ptr [i] // Привести в порядок стек shl eax, 2 add eax, 8 add esp, eax end; // Почистить строки for I:=low(Par) to High(Par) do case Par[I].VType of vtInteger : Inc(BufPtr,4); vtExtended: Inc(BufPtr,8); vtPChar : Inc(BufPtr,4); vtString, vtAnsiString : begin StrDispose(PChar(PPointer(BufPtr)^)); Inc(BufPtr,4); end; end; end; /*-----------------------------------------------------------------*/ В таком виде методика уже имеет смысл. Изменения при типах вызова cdecl / pascal понятны.
С уважением Владимир Переплетчик.
Смотрите также :
Компилятор синтаксических выражений
| Раздел Сокровищница | й Втюрин aka Nemo, дата публикации 01 августа 2002г. |
Компонент для выгрузки набора данных в дерево
TDBSTreeView1.0 — компонент предназначен для выгрузки набора данных в дерево.
Оганичение:
Таблица должна иметь вид такой(то есть там должны присутствовать такие поля(названия не имеет значения)): 1 ID - integer(глобальный идатификатор) 2 IDPARENT - integer (ссылка на родительскую запись в этой таблице). Самые верхние узлы имеют в IDPARENT = 0.... Например, такая таблица IDNode IDparent Name 1 0 Первый узел 2 0 Второй узел 3 1 Первый ребенок первого узла 4 1 Второй ребенок первого узла итд Вот, в общем-то, и все ограничение... Наследовалось от TTreeView, поэтому имеет все его свойства. Добавлены свойства
А если найдете ошибки(не граматические естейственно:)..) отпишите плз... а то исправите у себя, а я буду потом десять лет это отлавливать ок?:)
Александров Дмитрий
AlexDBases
Скачать : (9,6 К)
| Для данного материала нет комментариев. |
Компонент градиентной раскраски областей
| Раздел Сокровищница |
Для более правильного воспроизведения интенсивности цвета необходимо ввести тригонометрическую функцию преобразования интенсивности, но это сильно замедлит воспроизведение фигуры.
Для ускорения воспроизведения фигур в RunTime можно добавить в компонент преобразование рисунка в Bitmap после окончания режима разработки и далее воспроизводить его как картинку.
Компонент реализует градиентную заливку для конуса, цилиндра и сферы. В Design-time настраиваются все основные свойства псевдообъемной фигуры: тип фигуры и ее размер, расположение (кроме сферы), цвет заливки, смещения вершины конуса для получения скошенных и усеченных конусов. Для смены точки освещения и скошенных цилиндров допишете сами, это не сложно.
Проект, демонстрирующий градиентную заливку :
Компонент "Линия"
| Раздел Сокровищница | стa 2001 г. |
Компонент предназначен для вычерчивания линий на мнемосхемах и других целей, где количество ломаных линий, созданых одним компонентом, не должно превышать 255.
Инструмент - Delphi 5.1.
Введение даже списка (TList), не говоря уже о коллекции, заметно замедляло отрисовку, поэтому был выбран статический массив записей линий.
Компонент позволяет изменять тощину, стиль и цвет как в режиме разработки, так и в динамике.
Для редактирования используется стандартный редактор компонентов, запускаемый нажатием правой кнопкой мыши.
Редактирование нужно начинать с первой команды выпадающего меню (Edit Lines), а заканчивать - со второй (Exit from Editing). Редактирование заключается в добавлении линий (Add Line) и узлов (Add node), и удалении их (Remove Line и Remove Node).
Можно также менять цвет (Line Color) и стиль линии (LineStyle). Ввиду ограничений, накладываемых операционными системами Windows95 и 98, стили меняются только для линий с толщиной, равной 1. Для Windows NT и 2000 таких ограничений нет.
Для изменения координат узла нужно выбрать линию путем нажатия левой кнопки мыши над требуемым узлом или концом линии, и, удерживая ее, перетащить на нужное место. Выделенная линия обозначается черными квадратиками.
Для большего удобства в выпадающем меню редактора указывается общее количество созданых линий, номер выбранной линии и узлов в ней.
К сожалению, компонент имеет существенный недостаток - отсутствие блокировки манипулирования другими компонентами, находящимися на форме, до выхода из режима редактирования линий.
убоко благодарен за любые советы по преодолению указанного недостатка.
убокую благодарность Сергею Губенко и Юрию Зотову за ценные советы по построению компонента.
Компонент могут использовать все без всяких ограничений, но со ссылкой на автора.
Скачать исходные коды (7K)
Компонент MathParser
| нов, дата публикации 21 января 2002г |
Компонент MathParser разбирает математические выражения и вычисляет их. Математическое выражение может состоять из чисел (целых и действительных), переменных (любая последовательность букв и цифр начинающаяся с буквы), действий арифметики (плюс, минус, умножить, разделить, возвести в степень ), функций (любая последовательность букв и цифр начинающаяся с буквы и заканчивающаяся круглыми скобками) и скобки для задания приоритетов. Переменные и функции чувствительны к регистру.
Свойства Expression - тип String, математическое выражение, которое нужно вычислить. Например x^2+sin(exp(x))-b+2 Variables - тип TStrings, представляет набор переменных и их значений, разделенных знаком =. Например x=2 b=2 Методы Execute - возвращает значение выражения, при данных значениях переменных.
Возвращаемое значение имеет тип Real. Исключения
Компонент NXDBGrid, позволяющий отображать Dataset в транспонированном виде (столбцы в строках).
| Разделу Сокровищница |
Создание копонента было вызвано тем, что пришлось отображать объекты со множеством свойств, либо константных, либо изменяемых одновременно.
Стандартный ValueEditor не подходил по нескольким причинам:
Класс отнаследован от TCustomGrid, методы TCustomDBGrid были вставлены простым копированием и дополнены функциональностью.
NXDBGrid дополнен возможностью редактирования Даты\времени (т.к. мы отнаследователись от TCustomGrid то мы не смогли вставить стандартный редактор от MS как Inplace, поэтому пришлось написать самим ;-) )
Не смогли добавить дефолтный редактор компонента для DBGrid (по двойному щелчку мыши).
Не смогли реализовать добавление редакторов и валидаторов (Хотели использовать паттерн State (состояние) при изменении текущего столбца), но то ли мы не со всем разобрались, то ли ребята из Борланда замутили ;-)(у некоторых функций забыли поставить Virtual, некоторые объявлены в приватной области).
Добавлены проверки типов данных при редактировании.
Скриншоты :
Использование компонента состоит в изменении свойства Transformed
Технология использования компонента у нас простая. Создаем виртуальный рекордсет, запихиваем в него данные и выполняем присвоение
ADODataset.Recordset = наш рекордсет
Скачать компонент (93K)
и и основных моментов - Александр Ткаченко,
реализация - Денис Полеонов
материал предоставлен специально для
Компонент, позволяющий отображать формулы
| Раздел Сокровищница | в А.В., дата публикации 18 октября 2002г. |
Возможности
Для задания формулы используется текст свойства Caption. Формула описывается в текстовом режиме.
Зарезервированные символы
, '\', '^','_', '}','{'.
Для вывода зарезервированных символов необходимо использовать их совместно с символом \. Например для вывода пробела ипользуется \, правая фигурная скобка\}. Символы {} зарезервированы для дальнейшнго расширения.
Символы греческого алфавита и спецсимволы: \Delta, \Downarrow, \Gamma, \Lambda, \LeftArrow, \Leftrightarrow, \Omega, \RightArrow, \Phi, \Pi, \Psi, \Sigma, \Theta, \Uparrow, \Upsilon, \Xi, \alpha, \angle, \approx, \beta, \bullet, \cap, \cdot, \chi, \cong, \delta, \diamond, \div, \downarrow, \epsilon, \equiv, \eta, \gamma, \ge, \gets, \in, \infinity, \iota, \kappa, \lambda, \le, \mu, \ne, \notin, \nu, \omega, \oplus, \oslash, \otimes, \partial, \perp, \phi, \pi, \pm, \psi, \rho, \sigma, \subset, \subseteq, \supset, \tau, \theta, \times, \to, \uncup, \uparrow, \upsilon, \varepsilon, \varphi, \varpi, \varsigma, \vee, \wedge, \xi, \zeta.
Недостатки: невозможность использовать струтурные скобки {} работа только на одной базовой линии (нельзя использовать \frac) и т.д. Да и нельзя реализовать TeX в 20-30 строках кода.
Примеры: S=\pi R^2 -- площадь круга С_2 H_5 OH -- OН и есть \Delta \phi = 0 уравнение Пуассона
Скачать (5 K)
Компонент SystemTray
| Раздел Сокровищница | рбань С.В., дата публикации 25 сентября 2002г. |
| Компонент отличается от всех найденных мной аналогов. В нем не реализована только анимация (ну не нужна она мне...), зато он (компонент) САМ взаимодействует с формой и приложением. Это значит, что вы кладете компонент на форму, настраиваете настраиваете его (иконка, хинт, события мыши, всплывающее меню), задаете видимость формы, видимость приложения на панели задач и видимость иконки в трее. Все. Запускаете приложение. Если вы в DesignTime задали невидимую форму, невидимое приложение и видимый значек - ваше приложение появится ТОЛЬКО в трее. Если вы и значек спрятали - тогда вообще ничего не видно :-) Спрятались :-)) |  |
В архиве компонент и специальный пример — (236 K)
Компонент TADOUpdateSQL
| Раздел Сокровищница | ркуша Алексей, дата публикации 14 мая 2002г. |
Здесь представлены работающие компоненты обновления данных, полученных запросом через TADOQuery, аналогичные компонентам BDE TQuery,TUpdateSQL
Компоненты TADOUpdateQuery, TADOUpdateSQL выполняют в точности те же функции что и компоненты BDE TQuery,TUpdateSQL.
Это может способствовать быстрому переводу программ с BDE на ADO. Компоненты работающие (в исходных текстах есть комментарии), но до полной совместимости необходимы доработки, например: отсутствуют события onUpdateRecord, onUpdateError.
Предлагаю всем подключится и довести дело до конца.
type TADOUpdateQuery = class; TADOUpdateSQL = class; // Для правильной работы (логика) нежелательно изменять запрашиваемые поля TADOUpdateQuery = class (TADOQuery) private DelRecords: TADOQuery; FUpdateObject: TADOUpdateSQL; procedure SetUpdateObject(Value: TADOUpdateSQL); procedure ClearBuffer; // физическое удаление записей из буфера удаленных procedure InitBuffer; // создание датасета в которые помещаюися удаленные записи procedure FillBuffer; // перенос записи в буфер удаленных procedure ApplyDelUpdates; protected procedure InternalDelete; override; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure ApplyUpdates; // после успешного выполнения буфер удаленных записей будет пуст и необходим CommitUpdates // так как статусы "тронутых" записей не изменены //(пример вставка записи: будет столько сколько раз // был вызван ApplyUpdates. Неправильно это :-(, кто об этом знает procedure CancelUpdates; // сброс внутренних флагов ADO (вставленных, измененных) и сброс удаленных procedure CommitUpdates; // сброс внутренних флагов ADO (вставленных, измененных) published property UpdateObject: TADOUpdateSQL read FUpdateObject write SetUpdateObject; end; TADOUpdateSQL = class(TComponent) private FDataSet: TADOUpdateQuery; FQueries: array[TUpdateKind] of TADOQuery; FSQLText: array[TUpdateKind] of TStrings; function GetQuery(UpdateKind: TUpdateKind): TADOQuery; function GetSQLIndex(Index: Integer): TStrings; procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings); procedure SetSQLIndex(Index: Integer; Value: TStrings); protected function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; function GetDataSet: TADOUpdateQuery; virtual; procedure SetDataSet(ADataSet: TADOUpdateQuery); virtual; procedure SQLChanged(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Apply(UpdateKind: TUpdateKind); virtual; // не изменяет статусов записей // при прямом вызове сначала SetParams, не изменяет статусов записей procedure ExecSQL(UpdateKind: TUpdateKind); procedure SetParams(UpdateKind: TUpdateKind); // заполнение параметров property DataSet: TADOUpdateQuery read GetDataSet write SetDataSet; property Query[UpdateKind: TUpdateKind]: TADOQuery read GetQuery; property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL; published property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex; property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex; property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex; end; Скачать (5.7 K)
Компонент TComboBox с пошаговым поиском в списке
| Раздел Сокровищница |
Мне понадобился компонент TComboBox с пошаговым поиском в списке.
Несколько модифицированный стандартный TComboBox компонент с возможностью инкрементального поиска нашел на . Для Borland C++ Builder.
Переписал его на Delphi, может кому пригодится. Всю критику по коду приму по мылу. unit ComboBoxInc; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TComboBoxInc = class(TComboBox) private FTagString:AnsiString; FIncSearch:boolean; Findex:longint; Findex_prev:longint; FText_prev:string; FSelStart_prev:longint; protected procedure KeyUp(var Key:word; Shift:TShiftState);override; procedure KeyDown(var Key:word; Shift:TShiftState);override; public constructor Create (Owner:TComponent);override; published property IncSearch:boolean read FIncSearch write FIncSearch default true; property TagString:AnsiString read FTagString write FTagString; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TComboBoxInc]); end; procedure TComboBoxInc.KeyUp(var Key : word; Shift:TShiftState ); var start :integer; s:string; begin if (Key = 13) then begin start := 0; Findex_prev:=-1; Findex := SendMessage(Handle, CB_FINDSTRING, Findex-1, LongInt(PChar(Text))); FText_prev:=''; if (Findex <> -1) then SendMessage(Handle, CB_SETCURSEL, Findex, 0); SelStart := start; SelLength := GetTextLen()-start; Findex:=-1; inherited; end else begin if (FIncSearch) then begin if (key=8) then SelStart:=FSelStart_prev; start := SelStart; if (key <> 8) then Findex_prev:=Findex; Findex := SendMessage(Handle, CB_FINDSTRING, Findex-1,LongInt(PChar(Text))); FText_prev:=Text; if ((Findex <> -1)and not((Key = VK_DELETE))) then SendMessage(Handle, CB_SETCURSEL, Findex, 0); SelStart := start; SelLength := GetTextLen()-start; end; end; end; procedure TComboBoxInc.KeyDown(var Key : word; Shift:TShiftState ); begin if (Key=8) then begin SetLength(FText_prev,length(FText_prev)-1); Findex:=Findex_prev; Text:=FText_prev; end else FSelStart_prev:=SelStart; end; constructor TComboBoxInc.Create (Owner:TComponent); begin FIncSearch := true; FTagString := ''; inherited; end; end.
Компонент TOraCommentsToFL — загрузка русских наименований колонок из ERwin в DisplayLabels
| Раздел Сокровищница | й Седов , дата публикации 29 мая 2002г. |
Хочу поделиться идеей, которая, может и приходила уже кому-нибудь в голову, но я пока не встречал таких решений... Для тех, кто проектирует базы данных для Oracle в ERwin. Предлагаю решение для загрузки русских наименований колонок из ERwin в DisplayLabels датасета.
Компонент, конечно, сырой, но я пользуюсь, и очень поиогает. Ненавижу вбивать один текст по 10 раз.
Что нужно сделать:
Требуются установленные компоненты ODAC.
Скачать (3K)
Компоненты для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных
| Раздел Сокровищница |
Набор компонент писался для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных.
TAkLstDataпредназначена для вывода и выбора данных из набора данных в виде списка. Имеется возможность фильтрации этого списка. Множественный выбор. TAkTreeDataпредназначена для вывода и выбора данных из набора данных. Данные представлены в виде дерева. Существует возможность множественного выбора. TAkFilterDataпозволяет в диалоге задать условия отбора данных используемые в TQuery в разделе WHERE. TEditDataFormпозволяет получать данные (строка, дата, число) А-ля редактор свойств параметра ключа в реестре. TAkFindGridпозволяет искать данные в DBGrid. Компоненты оттестированы для Delphi 5 и необходимо наличие библиотеки RxLib.
Имеется краткая помощь и демо.
Скачать компоненты: (107K)
Компоненты для работы с графикой.
| Раздел Сокровищница | Юрий , 16 апреля 2001г. |
Несколько слов о сути моего материала. Прежде всего, он предназначена для программистов Delphi, работающих с графикой. Представленные компоненты имеют такие возможности, как:
А теперь рассмотрим вышеперечисленные пункты немного подробнее. Но для начала, несколько слов о принципах работы этих компонентов. Прежде всего они построены на основе массива объектов типа TBitmap. В 32 битных изображениях цвет кодируется 3 байтами - по одному на синий, зеленый и голубой, плюс добавляется один байт на альфа канал. В этот альфа канал записывается информация о том, следует ли при вставке одной картинки в другую использовать соответствующий пиксель (или игнорировать его). То есть по идее он может принимать два значения: 0 и 1. В этих компонентах использован несколько иной принцип использования альфа канала. Туда записывается число, которое представляет собой коэффициент, используемый при расчете двух пикселей двух различных картинок. То есть, если, скажем альфа канал равен 127, то результирующий пиксель будет являться средним арифметическим двух других пикселей. Значение альфа канала, равное 0 соответствует полной непрозрачности, а равное равное 255 - полной прозрачности вставляемой картинки. Процедура SetAlphaChannel устанавливает заданное значение альфа канала для всех пикселей картинки.
| Замена цветов |
Также в компонент TGraph добавлено несколько функция для замены цветов. Все эти процедуры работают только с 24 битными рисунками.
Вот, собственно все процедуры созданные для замены цвета. Вместе они представляют из себя довольно гибкое средство для работы с графикой. Еще одно достоинство - они работают достаточно быстро. Это касается также и других процедур, например на компьютере Pentium Celeron 400 расчет прозрачности двух картинок (обе были (конечно же) 32 битные, размером 1024 на 768) занимал на более 500 миллисекунд.
| Компонент TGraphGrid |
TIntArray = array of Integer; Оно представляет из себя массив ссылок. Поясню на примере. Пусть у на прорисовывается ячейка к координатами Col = 2, Row = 1, где в компоненте TDrawGrid 10 столбцов. В таком случае индекс ячейки (ее порядковый номер) будет равен 12 (нумерация столбцов и рядов начинается с нуля, с нуля также начинается нумерация индекса ячейки). При этом RefArray[12] = 1. В таком случае в ячейке Col = 2, Row = 1 будет прорисовываться картинку с индексом 1. При отсутствии ссылки не другую ячейку RefArray[N] = -1. В таком случае, при условии DefaultOrder = False в ячейке Col = 2, Row = 1 прорисовывалось бы именно картинка с индексом 12. Для более удобного доступа к массиву ссылок есть свойство: property Reference[Col, Row: Integer]: TGridCoord; TGridCoord = record Col, Row: Integer; end; Для задания переменной типа есть функция: function GridCoord(Col, Row: Integer): TGridCoord; Рассмотрим теперь событие, возникающее при прорисовки картинки в ячейке: TDrawPictureEvent = procedure(Sender: TObject; Rect: TRect; Index, Col, Row: Integer; var X, Y: Integer; Picture: TBitmap; var Background: TBitmap; var Continue: Boolean) of object; Параметры X и Y представляют собой координаты левого верхнего угла картинки (по умолчанию равны 0), которые можно изменять, Picture: собственно, сама картинка, Background картинка, по умолчанию равная nil. Если присвоить этому параметру значение, то картинка Background будет представлять собой фон ячейки. Также, если картинка Background по размерам меньше, ячейки, то она автоматически будет размножена. Также в компоненте TGraphGrid есть ряд свойств, которые, я думаю, объяснять не нужно, так как они интуитивно понятны (например свойство Scale - для автоматического масштабирования картинки и т.д.)
(153 K)
И, наконец, последний пункт - дополнение в виде движущегося текста. В компоненте TGraph также еще есть одна функция Appearance, но о ней я пока рассказывать не буду. procedure TGraph.AnimatedText(Canvas: TCanvas; Application: TApplication; Source: TBitmap; List: TStrings; Alignment: TAlignment; X, Y, Decrement: Integer; Delay: LongWord); Свойство Canvas представляет собой объект типа TCanvas на котором и будет осуществляться прорисовка. Application служит для вызова функции ProcessMessages. Source представляет собой фоновую картинку, Alignment - способ выравнивания текста, X, Y, координаты, по ним определяется границы движения текста, Decrement величина, определяющая через сколько пикселей текст будет перерисован. Delay - соответственно, задержка текста в миллисекундах.
(180 K)
Заключение
Если Вам удалось прочитать всю это до конца, то я уверен, Вы сможете найти практическое применение для моих компонентов, а скачать их можно здесь — (11 K)
Копирование на практике
Произведём копирование данных на практике. Для этого создадим новый проект под названием Test. Вносим название баз данных.Примечание:
Новая база данных (куда мы копируем) должна быть совершенно пустой. У меня её размер составляет 230 Кб. Т.е. в ней нет ничего, кроме системных таблиц InterBase и т.п..
Переходим на таблицу названий копируемых таблиц и заполняем в той последовательности, в которой хотим копировать. За последовательность отвечает столбец Сорт.
Примечание:
Последовательность важна, если мы при копировании информации не блокируем триггера и ограничения по вторичным ключам.
Там где поле Название заполняем название таблицы. Можно указать Русское название - поле чисто для информации на русском языке.
Если Вы применяете генераторы для ключевого поля, то необходимо заполнить поля Первичный, Название генератора, Название процедуры генератора. Тогда программа автоматически будет создавать генератор, устанавливать его значение по максимальному значению указанного Вами поля, а так же создавать хранимую процедуру для выборки значения генератора.
Так как мы копируем информацию в полностью пустую базу данных, то необходимо указать скрипты генерации базы данных. Для этого щёлкаем на закладке Файлы скриптов и указываем заполняем таблицу.
Примечание:
В качестве раздалителя в скриптах используется ^.
Вот и завершена предварительная работа перед копированием базы данных. Теперь можно перейти на закладку Проекты, отметить галочки отключений (если нужно и нажать на Перекачать информацию. (В моём случае даже не нужно отключение триггеров и ограничений).
Появится окно с информацией о процессе копирования информации и выполнения скриптов.
Это процесс длительный. Программа не забирает всё процессорное время и позволяет в это время Вам работать над другими задачам. При копировании таблиц показывается номер копируемой строки.
После завершения копирования показывается общее количество ошибок, предупреждений, ошибок в скрипте.
Вот мы и сгенерировали полностью работоспособную базу данных. И обошлось практически без потерь информации.
Рудюк Сергей
Лицензионное соглашение.
Лицензионное соглашение написано в каждом сооветствующем юните, здесь же написано некоторое пояснение :TRySharedMem и TRySharedStream - это, по большому счету, базируются на результате(ах) работы FileMappingFunctions, но немалое значение здесь имеет и человеческий фактор: как вы распорядитесь объектами отображения, какой файл вы отобразите и что, как и сколько вы туда запишите никто не может знать, а файловая область, как вы знаете, это не шутка. Поэтому программный код дается вам бесплатно, по принципу "as is". асны с лицензионным соглашением или с некоторыми пунктами - вы не должны использовать данный програмный код в ваших проектах.
ListBox с расшифровкой длинных строк
В некоторых программах я встречал очень удобный дополнительный интерфейс стандартного списка ListBox: при наведении мышки на строчку, которая по ширине полностью не помещалась в контроле, рядом всплывало поясняющее окошко содержащее эту строчку целиком. Это очень удобный интерфейс; если пользователю хочется уточнить, что же в точности написано в скрытой строке списка, то ему не надо расширять/сужать форму, дергать Spliter'ы и так далее, достаточно просто подвести мышку к интересующей его строке.
Когда мне понадобилось снабдить таким интерфейсом ListBox в одном из моих проектов, я решил, что для решения этой задачи можно воспользоваться каким-нибудь сторонним компонентом. Но вот беда, на Torry такого компонента я не нашел. Поиск по другим сайтам выявил несколько похожих компонент, но все они были какими-то недоделанными, самопальными...
Видимо, подумал я, этот компонент легче написать самому; благо тут нет ничего сложного. Так я и сделал. Получились два довольно приличных компонента TTipListBox и TTipCheckListBox, которые и предлагаются вашему вниманию.
С интересом выслушаю все соображения по улучшению функциональности компонента и упрощению его кода. Собственно, я и выкладываю-то эти компоненты ради обсуждения их общественностью. :)
Исходники компонентов и демонстрационный проект (Delphi 5) (7K)
Специально для
Смотрите по теме:
Матрицы в Delphi
| Раздел Сокровищница |
Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.
Я понимаю, что уровень подготовки наших преподавателей весьма отстает не то, что от нынешних технологий, но даже и от весьма более ранних, но все-таки попробую помочь собратьям "по-несчастью".... :o)))
Итак, в приведен исходный текст весьма простенькой библиотеки Matrix.pas...
Перечень функций этой библиотеки: type MatrixPtr = ^MatrixRec; MatrixRec = record MatrixRow : byte; MatrixCol : byte; MatrixArray : pointer; end; MatrixElement = real; (* Функция возвращает целочисленную степень *) function IntPower(X,n : integer) : integer; (* Функция создает квадратную матрицу *) function CreateSquareMatrix(Size : byte) : MatrixPtr; (* Функция создает прямоугольную матрицу *) function CreateMatrix(Row,Col : byte) : MatrixPtr; (* Функция дублирует матрицу *) function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция удаляет матрицу и возвращает TRUE в случае удачи *) function DeleteMatrix(var MPtr : MatrixPtr) : boolean; (* Функция заполняет матрицу указанным числом *) function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean; (* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *) function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr; (* Функция отображает матрицу на консоль *) function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean; (* Функция возвращает TRUE, если матрица 1x1 *) function IsSingleMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает TRUE, если матрица квадратная *) function IsSquareMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает количество строк матрицы *) function GetMatrixRow(MPtr : MatrixPtr) : byte; (* Функция возвращает количество столбцов матрицы *) function GetMatrixCol(MPtr : MatrixPtr) : byte; (* Процедура устанавливает элемент матрицы *) procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement); (* Функция возвращает элемент матрицы *) function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция исключает векторы из матрицы *) function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr; (* Функция заменяет строку(столбец) матрицы вектором *) function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr; (* Функция возвращает детерминант матрицы *) function DetMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает детерминант треугольной матрицы *) function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает алгебраическое дополнение элемента матрицы *) function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция создает матрицу алгебраических дополнений элементов матрицы *) function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция транспонирует матрицу *) function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция возвращает обратную матрицу *) function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция умножает матрицу на число *) function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr; (* Функция умножает матрицу на матрицу *) function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция суммирует две матрицы *) function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция вычитает из первой матрицы вторую *) function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция решает систему методом Гаусса и возвращает LU-матрицы *) (* Результат функции - вектор-столбец решений *) function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;
Мне кажется, что интерфейсное описание весьма простое, но если возникнут какие-либо вопросы - пишите на E-mail - постараюсь ответить на все Ваши вопросы. Может быть, азы матричного исчисления я опишу в виде отдельной статьи по причине множества поступивших вопросов, хотя в этой матричной математике нет ничего сложного :o) Следует отметить, что теория матриц дает в Ваши руки весьма мощный инструмент по анализу данных весьма различного характера, в чем я неоднократно убеждался на практике.
Важные, на мой взгляд, замечания. НЕ СТЕСНЯЙТЕСЬ использовать подход, использующий стандартный тип Pascal - record - в объектах мало чего хорошего в межкомпиляторном взаимодействии. Да и, кстати, использование типа record до сих пор является самым быстрым способом математических расчетов, в отличиие от ООП. Частенько простое 2+2=4 дает существенный выигрыш по времени выполнения, по сравнению с объектным подходом, а если математических вычислений в Вашей программе великое множество....
P.S. Касательно уровня подготовки наших институтских кадров - эта библиотека сдавалась в качестве лабораторного задания аж в трех уральских университетах (кроме скромной персоны студента (ну, это и понятно ;o), и столь простые принципы работы доказывались чуть ли не перед комиссией от кафедры... ;o)))
С уважением,
Специально для
Скачать библиотеку (4 K)
Меню на основе панели инструментов
| Раздел Сокровищница |
Наверное многие видели меню, которое используется в MS Office или в самой среде Delphi: главные пункты выглядят как flat-кнопки -- плоские, но при перемещении над ними мыши как бы вспухающие. Кроме того, меню оформлено как панель инструментов и может пристыковываться к окну в любом месте.
Я предлагаю вариант реализации такого меню стандартными средствами VCL.
Сразу замечу, что чтобы двигать меню произвольным образом нужно возиться дополнительно ? TToolBar такой возможности не предоставляет.
Само меню оформляется как объект класса TToolBar, главные пункты меню ? стандартные для панели инструментов кнопки TToolButton, выпадающие подменю ? объекты TPopupMenu.
Итак, по пунктам.
1. Создаётся обычная панель инструментов MenuBar: TToolBar У неё устанавливаются следующие свойства: Color = clMenu //цвет как у меню AutoSize = TRUE // нельзя. 2. Создаются кнопки-главные элементы меню, класс TToolButton. У каждой кнопки устанавливаются свойства: AllowAllUp = TRUE AutoSize = TRUE Grouped = TRUE Caption = "Название пункта меню" 3. Для каждой кнопки создаётся своё подменю ? объект класса TPopupMenu В каждом из подменю задаётся соответствующий список пунктов. У кнопок на панели MenuBar свойство DropdownMenu заполняется ссылкой на соответствующий объект TPopupMenu.
Всё? Нет. К сожалению установленный в системе шрифт нельзя задать в design-режиме, а потому: 4. Когда-нибудь, до использования меню (например в обработчике события формы OnCreate) должен исполниться следующий код: var nc: TNonClientMetrics; s: TFontStyles; . . . . begin . . . . //читаем системные настройки в структуру nc nc.cbSize := sizeof(nc); SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(nc), @nc, 0); with MenuBar.Font do begin Charset := nc.lfMenuFont.lfCharSet; //устанавливаем charset Height := nc.lfMenuFont.lfHeight; //высоту шрифта Name := nc.lfMenuFont.lfFaceName; //гарнитуру шрифта //далее определяем набор стилей s := []; if nc.lfMenuFont.lfWeight >= FW_BOLD then s := s + [fsBold]; if nc.lfMenuFont.lfItalic <> 0 then s := s + [fsItalic]; if nc.lfMenuFont.lfUnderline <> 0 then s := s + [fsUnderline]; if nc.lfMenuFont.lfStrikeOut <> 0 then s := s + [fsStrikeOut]; Style := s; end; 5. Есть ещё один существенный недостаток. Созданное описанным образом меню не считается таковым с точки зрения Windows. Самое явное последствие ? оно не подсвечивается по нажатию клавши Alt. Исправить данный недостаток удалось написанием обработчика сообщения WM_SYSCOMMAND, которое вызывается, в частности, для выделения пункта меню по горячей клавише.
Заведите новый метод в private-секции формы с меню (имя метода и параметра роли не играет): procedure SysCommand(var M: TWMSysCommand); message WM_SYSCOMMAND; Реализация метода такова (код основан на исходниках TToolBar): procedure TMain.SysCommand(var M: TWMSysCommand); begin //проверяется, что это команда - menu accelerator key, что дополнительной //кнопки не нажато (только Alt), что никто не захватил (capture) мышь if (M.CmdType and $FFF0 = SC_KEYMENU) and (M.Key = 0) and (GetCapture() = 0) then begin MenuBar.TrackMenu(nil); //аргумент это кнопка, подменю которой вывалится; nil-никакой, такова //стандартная реакция; если хотите, чтобы подменю первой кнопки //сразу развернулось напишите MenuBar.TrackMenu(MenuBar.Buttons[0]); //можно и просто указать компонент-кнопку: MenuBar.TrackMenu(mb_Options); end else inherited; //условие не выполнили - обрабатываем по умолчанию end; Здесь правда возникает другая проблема -- становится недоступным через клавиатуру системное меню (которое с Переместить/Закрыть и пр.), но это уже не самое страшное. Вот теперь всё! Можете запускать программу и смотреть что получилось.
Несколько замечаний.
P.S. Уже после публикации статьи ко мне поступила просьба поместить ссылку на ресурс, который содержит интересную реализацию toolbar-меню:
По сути, это pas-файл, описывающий компонент - наследник TToolBar, в который добавлены дополнительные возможности. А именно: (а) необходимые свойства TToolBar (см. выше) устанавливаются сразу в нужные значения; (б) добавлено свойство Menu: TMainMenu, позволяющее автоматически создать toolbar-меню, на основе существующего главного меню.
Основным недостатком можно считать отсутствие синхронизации между обычным главным меню и создаваемым toolbar-меню. Плюс, учтите всё сказанное во втором замечании.
Достоинство в том, что это законченный компонент, которому достаточно задать свойство Menu и не мучаться больше -- всё остальное оформление он выполнит сам.
Методы фильтрации
Помимо описываемых ниже методов, присущих только TTable, наюоры данных имеют также общие свойства, методы и события для фильтрации - Filter, Filtered, OnFilteredRecord, FindFirst, FindLast, FindNext, FindPrior.Для фильтрации записей TTable имеет следующие методы:
> SetRangeStart - устанавливает нижнюю границу фильтра;
> EditRangeEnd - утанавливает верхнюю границу фильтра;
> ApplyRange - осуществляет фильтрацию записей в TTable;
> SetRange - имеет тот же эффект, что и последовательное выполнение методов SetRangeStart, EditRangeEnd и ApplyRange. В качестве параметров используются масивы констант, каждый из которых содержит значения ключевых полей.
Фильтрация методами ApplyRange, SetRange должно проводиться по ключевым полям.По умолчанию берется текущий индекс, определяемый свойством TTable.IndexName или TTable.IndexFieldNames. Если значения этих свойств не установлены, по умолчанию используется главный индекс. Поэтому, если нужно использовать индекс, отличный от главного, необходимо явно переустановить значение свойства TTable.IndexName (имя текущего индекса) или TTable.IndexFieldNames (список полей текущего индекса).
Многострочный Hint
| Раздел Сокровищница | врилов Сергей, дата публикации 26 ноября 2002г. |
Данный модуль является компонентом со стандартной процедурой установки. Работает в среде Delphi 6.
После его регистрации перекрывается редактор свойства Hint в TControl (т.е. во всех control-ах) во время Design-а.
При этом изменяется способ редактирования свойства Hint. У него появляется кнопка "...", он становится многострочным и > 255 символов.
Длинные хинты дольше читать, и, возможно, Вам потребуется изменить свойства (пример): Application.HintPause := 700; Application.HintHidePause := 10000; По умолчанию установлено 500мс и 2500мс
Текст модуля:
| unit HintProperty; interface uses Windows, Messages, SysUtils, Classes, designintf, DesignEditors, vcleditors, StdCtrls, StrEdit; type THintProperty = class(TStringListProperty) protected ss : TStringList; function GetStrings: TStrings; override; procedure SetStrings(const Value: TStrings); override; end; procedure Register; implementation uses Controls; procedure Register; begin RegisterPropertyEditor(TypeInfo(string), TControl, 'Hint', THintProperty); end; function THintProperty.GetStrings: TStrings; begin ss := TStringList.Create; ss.Text := GetStrValue; Result := TStrings(ss); end; procedure THintProperty.SetStrings(const Value: TStrings); var l : integer; s : string; begin s := value.Text; l := Length(s); if (l > 0) then SetLength(s, l-2); // чтобы не добавляла в конце пустую строку SetStrValue(s); ss.Destroy; end; end. |
Буду признателен за замечания. Гаврилов Сергей
ноябрь 2002г.
Модуль для печати таблиц TStringGrid
| Раздел Сокровищница |
Может кому-то будет полезен.
Из модуля PrintGrid:
| //процедура печати StringGrid Var //отступы (поля) сверху и слева страницы LeftMarg,TopMarg:Integer; //переменная для хранения значения отступа сверху от страницы для текущей //строки (в пикселях) CurrLine, //переменная для хранения значения отступа слева от страницы длч положения левой //границы текущей ячейки (в пикселях) LeftBorder, //тоже для правой границы текущей ячейки RightBorder, //переменная для хранения значения отступа сверху от страницы для положения верхней //границы текущей ячейки (в пикселях) TopBorder, //тоже для нижней границы текущей ячейки BottomBorder, //текущая строка таблицы Row, //текущий столбец таблицы Col:Integer; //отступ текста от левой границы ячеки LeftOffset:Integer; //счетчик страниц PageCount:Integer; //флаг конца страницы PageEnded:Boolean; //позиция для печати номеров страниц PageCountPrnPos:Integer; //диалог принтера PrintDialog:TPrintDialog; |
Другие небольшие статьи, примеры и программы можете найти на
Скачать пример (35K)
Смотрите так же:
Модуль для получения интервала дат
| Модуль предназначен для визуального выбора пользователем интервала дат с различными настройками. В модуле находится одна единственная функция function GetPeriod(var StartDate, EndDate: TDateTime): Boolean; Выходные параметры: |  |
Модуль для расчета числовых и логических формул
| Раздел Сокровищница |
Модуль предназначен для расчета любых математических или логических выражений. В него уже включен набор стандартных математических и логических функций, но можно создавать свои функции любых типов. Можно также создавать свои типы данных. Логика работы с модулем такова, что сначала создается формула, которая затем преобразуется в цифровой вид, т.н. сценарий, по которому будет производиться расчет.
Это нужно для того, чтобы оптимизировать расчет формулы, при этом достигается огромный выигрыш в скорости. Для примера: у меня на компьютере (Athlon 1800XP, 512 MB DDR) расчет средней формулы 10000000 раз происходит за 1 - 1,5 секунды. Это при оптимизированном расчете. А при обычном (мои самые первые неудачные варианты) расчет той же формулы 10000 раз занимал около полминуты. Под словом "средней" я имею ввиду не очень длинную формулу, которая не перегруженна большим количеством функций. Но на саму формулу не накладывается вообще никаких ограничений, она может иметь любое количество операндов, она также может иметь любое количество вложенных выражений.
Вложеннное выражение - это с технической точки зрения отдельная формула, которая находится внутри другой формулы и может иметь еще любое количество вложенных формул. А с точки зрения пользователя это просто выражение, заключенное в скобки и обладающее приоритетом в вычислении.
Краткое описание функций модуля:
Ora2DBF - Функция конвертации данных из Oracle в DBF файл
Параметры:
Параметры:
Смотрите также :
Модуль потоковой записи/чтения структуры и данных объекта TRxMemoryData.
| ста 2003г. |
RxLib - одна из самых лучших Delphi-библиотек, уже давно ставшая классикой разработки. В ее составе содержится компонент TRxMemoryData - "таблица в памяти", работающая напрямую, без каких-либо дополнительных платформ. Компонент очень удобен для операций с относительно небольшими объемами данных. Разумеется, можно использовать очень качественный и многофункциональный TClientDataSet, однако в условиях разработки на версиях Delphi младше D5 отсутствует возможность поставки приложения без дополнительных DLL. Кроме того, TRxMemoryData гораздо меньше добавляет веса к исполняемому модулю.
Процедуры потоковой записи-чтения позволят организовать на базе TRxMemoryData простую и гибкую систему хранения информации, удобную для реализации задач, оперирующих данными сравнительно небольших объемов, с доступом "по законам" TDataSet. Ниже приводится полный текст модуля.
Проверено на Delphi4 + RxLib 2.75.
Скачать (3K)
| unit RxMemDSUtil; // --------------------------------------------------------------------------------------- // Дополнительные инструменты для работы с TRxMemoryData // --------------------------------------------------------------------------------------- interface uses Classes, SysUtils, RxMemDS; type // Прикладные исключения записи и чтения (сообщения на русском) ERxMemoryDataWriteError = class(Exception); ERxMemoryDataReadError = class(Exception); // Обратная связь при чтении-записи TReadWriteRxMemoryDataCallback = procedure(ACurrent, ATotal : Integer; var ACancel : Boolean) of object; // Запись в поток. При ошибках генерируются исключения. procedure WriteRxMemoryDataToStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Чтение из потока (структура и данные будут загружены из потока "как есть" - без учета текущей структуры). // При ошибках генерируются исключения. procedure ReadRxMemoryDataFromStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Запись в файл. При ошибках генерируются исключения. procedure WriteRxMemoryDataToFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word = (fmCreate or fmOpenWrite or fmShareDenyWrite); ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Чтение из файла. При ошибках генерируются исключения. procedure ReadRxMemoryDataFromFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word = (fmOpenRead or fmShareDenyWrite); ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); implementation uses DB, TypInfo; // --------------------------------------------------------------------------------------- // Внутрение типы и константы // --------------------------------------------------------------------------------------- const // Поддерживаемые типы полей (запись, чтение) DefProcessableFields : set of TFieldType = [ ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes ]; // --------------------------------------------------------------------------------------- // Внутрение вызовы // --------------------------------------------------------------------------------------- procedure _WriteFieldValueToStream(AField : TField; AWriter : TWriter); var tmpBool : Boolean; begin with AField, AWriter do begin // Отслеживаем NULL-значение tmpBool := (IsNull and (not (DataType in [ftBlob, ftMemo, ftGraphic, ftFmtMemo]))); WriteBoolean(tmpBool); if(tmpBool) then exit; // Строка или бинарные данные if((DataType in [ftString, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes]) or IsBlob) then WriteString(AsString) else begin case(DataType) of // Целое ftSmallint, ftInteger, ftWord, ftAutoInc : WriteInteger(AsInteger); // Логическое ftBoolean : WriteBoolean(AsBoolean); // Вещественное ftFloat : WriteFloat(AsFloat); // Валюта ftCurrency : WriteCurrency(AsCurrency); // Дата и время ftDate, ftTime, ftDateTime : WriteDate(AsDateTime); else raise ERxMemoryDataWriteError.Create('Неожиданная ошибка записи (неизвестный тип поля).'); end; end; end; end; procedure _ReadFieldValueFromStream(AField : TField; AReader : TReader); begin with AField, AReader do begin // Отслеживаем NULL-значение if(ReadBoolean) then begin Value := NULL; exit; end; // Строка или бинарные данные if((DataType in [ftString, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes]) or IsBlob) then AsString := ReadString else begin case(DataType) of // Целое ftSmallint, ftInteger, ftWord, ftAutoInc : AsInteger := ReadInteger; // Логическое ftBoolean : AsBoolean := ReadBoolean; // Вещественное ftFloat : AsFloat := ReadFloat; // Валюта ftCurrency : AsCurrency := ReadCurrency; // Дата и время ftDate, ftTime, ftDateTime : AsDateTime := ReadDate; else raise ERxMemoryDataReadError.Create('Неожиданная ошибка записи (неизвестный тип поля).'); end; end; end; end; procedure _Callback(ACallback : TReadWriteRxMemoryDataCallback; ACurrent, ATotal : Integer; AExceptionClass : ExceptClass); var tmpCancel : Boolean; tmp : String; begin if(not Assigned(ACallback)) then exit; tmpCancel := False; try ACallback(ACurrent, ATotal, tmpCancel); if(tmpCancel) then begin tmp := ' '; if(AExceptionClass = ERxMemoryDataWriteError) then tmp := ' записи '; if(AExceptionClass = ERxMemoryDataReadError) then tmp := ' чтения '; raise AExceptionClass.Create('Процесс' + tmp + 'прерван.'); end; finally tmp := ''; end; end; // --------------------------------------------------------------------------------------- // Внешние вызовы // --------------------------------------------------------------------------------------- // Запись в поток. При ошибках генерируются исключения. procedure WriteRxMemoryDataToStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpWriter : TWriter; tmpRecNo : Integer; i, n : Integer; begin // Проверка параметров if(not Assigned(AObject)) then raise ERxMemoryDataWriteError.Create('Неверный параметр (AObject).'); if(not Assigned(AStream)) then raise ERxMemoryDataWriteError.Create('Неверный параметр (AStream).'); if(ABufSize 'Неверный параметр (ABufSize).'); with AObject do begin // Получаем текущую позицию (заодно проверям активность таблицы) tmpRecNo := RecNo; // Проверяем типы полей for i := 0 to Fields.Count - 1 do begin if(not (Fields[i].DataType in DefProcessableFields)) then raise ERxMemoryDataWriteError.Create('Поля данного типа не поддерживаются (поле ' + Fields[i].FieldName + ', тип ' + GetEnumName(TypeInfo(TFieldType), Integer(Fields[i].DataType)) + ').'); end; end; // Далее AObject.DisableControls; tmpWriter := TWriter.Create(AStream, ABufSize); try with tmpWriter, AObject do begin // Вызываем callback _Callback(ACallback, 0, RecordCount, ERxMemoryDataWriteError); // Пишем сигнатуру и тип класса WriteSignature; WriteString(ClassName); // Пишем структуру WriteCollection(FieldDefs); // Пишем данные WriteInteger(RecordCount); WriteListBegin; First; n := 0; while(not EOF) do begin for i := 0 to Fields.Count - 1 do _WriteFieldValueToStream(Fields[i], tmpWriter); Inc(n); // Вызываем callback _Callback(ACallback, n, RecordCount, ERxMemoryDataWriteError); // Далее Next; end; WriteListEnd; if(n <> RecordCount) then raise ERxMemoryDataWriteError.Create('Неожиданная ошибка (несовпадение количества записей).'); // Все FlushBuffer; end; finally tmpWriter.Free; AObject.RecNo := tmpRecNo; AObject.EnableControls; end; end; // Чтение из потока (структура и данные будут загружены из потока "как есть" - без учета текущей структуры). // При ошибках генерируются исключения. procedure ReadRxMemoryDataFromStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpReader : TReader; i, j, n : Integer; begin // Проверка параметров if(not Assigned(AObject)) then raise ERxMemoryDataReadError.Create('Неверный параметр (AObject).'); if(not Assigned(AStream)) then raise ERxMemoryDataReadError.Create('Неверный параметр (AStream).'); if(ABufSize 'Неверный параметр (ABufSize).'); // Проверяем - открыта ли таблица ? (и на чтении, и на записи - должна быть открыта) // AObject.Next; // Далее AObject.DisableControls; tmpReader := TReader.Create(AStream, ABufSize); try with tmpReader, AObject do begin // Чистим таблицу Open; EmptyTable; Close; FieldDefs.Clear; Fields.Clear; // Вызываем callback _Callback(ACallback, 0, 0, ERxMemoryDataReadError); // Читаем сигнатуру и тип класса ReadSignature; if(ReadString <> AObject.ClassName) then raise ERxMemoryDataReadError.Create('Несоответствие типов сохраненного объекта и объекта назначения.'); // Читаем структуру ReadValue; ReadCollection(AObject.FieldDefs); // Открываем Open; // Проверяем типы полей for i := 0 to Fields.Count - 1 do begin if(not (Fields[i].DataType in DefProcessableFields)) then raise ERxMemoryDataReadError.Create('Поля данного типа не поддерживаются (поле ' + Fields[i].FieldName + ', тип ' + GetEnumName(TypeInfo(TFieldType), Integer(Fields[i].DataType)) + ').'); end; // Читаем данные n := ReadInteger; ReadListBegin; j := 0; while(j <> n) do begin Append; for i := 0 to Fields.Count - 1 do _ReadFieldValueFromStream(Fields[i], tmpReader); Post; Inc(j); _Callback(ACallback, j, n, ERxMemoryDataReadError); end; ReadListEnd; if((j <> n) or (n <> RecordCount)) then raise ERxMemoryDataReadError.Create('Неожиданная ошибка (несовпадение количества записей).'); First; // Все end; finally tmpReader.Free; AObject.EnableControls; end; end; // Запись в файл. При ошибках генерируются исключения. procedure WriteRxMemoryDataToFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpStream : TFileStream; begin tmpStream := TFileStream.Create(AFileName, AFileMode); try WriteRxMemoryDataToStream(AObject, tmpStream, ABufSize, ACallback); finally tmpStream.Free; end; end; // Чтение из файла. При ошибках генерируются исключения. procedure ReadRxMemoryDataFromFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpStream : TFileStream; begin tmpStream := TFileStream.Create(AFileName, AFileMode); try ReadRxMemoryDataFromStream(AObject, tmpStream, ABufSize, ACallback); finally tmpStream.Free; end; end; // --------------------------------------------------------------------------------------- end. |
Скачать (3K)
Модуль реализации матричных вычислений для массивов больших размеров
В этом модуле «осели» все операции с матрицами и векторами, которые я использовал для работы. Но есть алгоритмы, которые многие, наверняка, увидят впервые: Divide – алгоритм прямого деления, MSqrt – квадратный корень, MAbs – абсолютная величина. Поскольку модуль содержит все, от элементарных операций до матричных, разобраться будет несложно:
Например, решение системы ЛУ( консольное приложение )
| Var N : Integer; A : Matrix; b, x : Vector; begin N := . . .; A.Init( N, N ); b.Init( N ); x.Init( N ); // или x.Init( B ); или x.InitRow( A ); . . . { формирование A и b } . . . x.Divide( b, A ); x.Print; . . . end. |
Некоторые алгоритмы требуют пояснения, например: Matrix.E( i, j : LongWord ) или Vector.E( i : Integer ) : RealPtr, (RealPtr = ^Real) функция для вычисления адреса элемента матрицы/вектора. Перешла из ДОС когда в модуле использовался алгоритм управления виртуальной памятью для больших размерностей. Matrix.Multiple( X, Y : Vector ) Результатом, которого является произведение вектора X на транспонированный вектор Y - матрица ранга 1. Matrix.Invert( A : Matrix ) – если A[N,M], и N <> M то результат – матрица размера [M,N] – псевдообратная = A+. Matrix.Addition( A : Matrix; B : Real ) – добавление числа в главную диагональ. Matrix.Diag( r : Real ) – присваивание значения главной диагонали. Когда есть исходный текст - разобраться можно всегда.
Этот модуль используется почти во всех реализованных мной численных алгоритмах и методах. Те части, которые писал не я – приводятся без изменений(по возможности) стиля и комментариев.
Скачать (14K)
Модуль VHeapLow — модуль для работы с виртуальной памятью
Этот модуль был написан в 1992 году, для разработки приложений требующих большой объем памяти для хранения и обработки данных. Обычно такие задачи возникают при программной генерации систем уравнений ( линейных или дифференциальных ). Поддержку больших массивов в программе можно увидеть, например, в Turbo Proffesional. Модуль VheapLow - своеобразная реализация механизма управления виртуальной памятью построенная по образу кучи Turbo Pascal. Применение виртуальной памяти это самое очевидное решение проблемы. С развитием железа и ОС барьер в 640k перестал быть препятствием для решения задач большой размерности. А с этим и актуальность, даже очень крутых реализаций, виртуальных массивов отпала ( естественно, зачем нужна двойная виртуализация ? Я, и сам переделывал свои задачи для работы без этого модуля. Переделывается - очень просто: GetVMem - заменяется на GetMem, а FreeVMem на FreeMem.)
Но, совсем недавно, появилась задача обработки больших объемов текстовой информации, и соответственно возник вопрос как ее хранить и накапливать. Самое простое решение - вообще не выгружать программу из памяти, самое сложное - база данных. Но базу данных со сложной организацией данных вполне можно заменить виртуальной кучей( Virtual Heap ), и работать с ней как с обычной памятью. Поскольку блоки памяти, выделенные в виртуальной куче, можно сохранять сколько угодно долго после завершения программы, добавлять и изменять при последующих запусках. Виртуальная куча - это отображение на дисковом пространстве реальной выделенной памяти. Физически виртуальная куча - файл на диске. В заголовке такого файла есть место для нескольких виртуальных адресов пользователя( см. исх. текст ). По ним можно разместить адреса начал всех цепочек данных, а ООП дает очень удобные механизмы для реализации программы.
Основные функции VheapLow :
| Type MyRec = Record A, B : Real; Q, X : Integer; End; MyRecPtr = ^MyRec; VMayRec = object VAddr : VirtualPtr; {- Virtual heap Address -} function Addr : MyRecPtr; procedure Init; procedure Free; end; function VMyRec.Addr : MyRecPtr; begin RESULT := VirtualToPtr( VAddr ); End; Procedure VMyRec.Init; Begin VAddr := GetVMem( SizeOf( MyRec ) ); End; Procedure VmayRec.Free; Begin FreeVMem( Vaddr ); End; ... Var MR : VMayRec; Begin // InitVHeap( имя файла, оставить после выполнения программы) InitVHeap( 'F.vhp', True ); if VHeapStatus = OldVHeap then MR.VAddr := VHBases[ User01 ] else MR.Init; ... With MR.Addr^ do begin Q := Pi; ... ... |
Первая записывает строка в виртуальную память и возвращает виртуальный адрес, вторая по виртуальному адресу возвращает строку.
Модуль еще не полностью переделан под среду Delphi. В нем исправлены лишь явные ошибки, мешающие компилятору. Реализовать все можно абсолютно по-другому и на более высоком уровне. Я, хотел лишь осветить саму идею. Могу добавить, что под ДОС все работало. Была даже программа для разработки структур данных виртуальной памяти. Результатом ее работы был исходный текст модуля с описанием типов объектов и реализацией их методов. К сожалению, программа и ее исходный текст были потеряны вместе с HDD…
| {$A-} unit VHEAPLow; {*********************************************************} {* VHEAPLOW.PAS 7.0 *} {* Writen by HNV 1991,92. *} {* Low level support for virtual heap. *} {*********************************************************} interface uses Classes, Dialogs, OpStrDev, SysUtils; const MaxFree = 256; {- size of free list -} type VirtualPtr = Real; VirtualPtrRec = record Len : LongWord; Addr : LongWord; end; Base = array[ 0..11 ] of VirtualPtr; UserBasesType = ( User01, User02, User03, User04, User05, User06, User07, User08, User09, User10 ); VHeapStatus = { Virtual Heap Status } ( NewVHeap, OldVHeap ); const UseKeyAccess : Boolean = false; { True if use key access } ShowHeapStatus : Boolean = false; { True if need show statistics } MaxHeapSpace : LongWord = 0; { Disk Free } } SaveVHeap : Boolean = False; { true if need saving v-heap } VHeapOk : Boolean = true; { VHeap Error flag } BaseAddr : Base = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ); VHeapCacheProc : Pointer = nil; { Addres of function VirtualToPtr } VHeapErrorProc : Pointer = nil; { Addres of VHeap error routine } {- Virtual Heap File Caching -} MaxCacheSize : LongWord = 0; {- Maximum size of cache -} CacheHeapRatio : Real = 0.5; {- CacheSize / HeapSize -} BytesInCache : LongWord = 0; {- Cache use -} MinCacheLevel : Byte = 8; {- Min number of caching records -} CacheLevel : LongWord = 0; {- Current number of caching records -} CacheRead : LongWord = 0; {- Number of reading records -} CacheWrite : LongWord = 0; {- Number of swaping records -} CacheHits : LongWord = 0; {- Number of cache hits -} CacheEff : Real = 0; {- Caching effect -} CacheSearch : LongWord = 0; {- Cache routine calls -} var VHBases : array[ UserBasesType ] of VirtualPtr Absolute BaseAddr; VHStatus : VHeapStatus; {- Virtual Heap status -} type StringPtr = ^string; VString = object VAddr : VirtualPtr; {- Virtual heap Address -} function Addr : StringPtr; procedure Init; procedure Free; end; procedure InitVHeap( FName : string; Save : Boolean ); {- Initiator of Virtual Heap -} function GetVMem( L : Word ) : VirtualPtr; {- Allocate virtual space -} procedure FreeVMem( V : VirtualPtr ); {- Deallocate virtual space -} function VirtualToPtr( V : VirtualPtr ) : Pointer; {- Converted a virtual pointer to real pointer -} function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to real pointer -} procedure SetCaching( TF : Boolean ); {- Turn Caching OFF if TF is false. -} function StructToVHeap( var S; L : Word ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} procedure StructFromVHeap( var S; V : VirtualPtr ); {- Return S at virtual pointer V -} function StringToVHeap( S : string ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} function StringFromVHeap( V : VirtualPtr ) : string; {- Return S at virtual pointer V -} procedure Statistics( ST : TStrings ); {- Show virtual heap staistics on the screen. -} implementation type FreeListA = array[ 1..MaxFree ] of VirtualPtrRec; FreeListV = array[ 1..MaxFree ] of VirtualPtr; FreeListVHeap = record NFree : LongWord; case Byte of 1 : ( FreeL : FreeListA ); 2 : ( FreeV : FreeListV ); end; FreeListPtrV = ^FreeListVHeap; type CacheAddr = ^CacheRec; CacheRec = record Next : CacheAddr; RecA : Pointer; case byte of 1 : ( HAddr : VirtualPtr ); 2 : ( VRec : VirtualPtrRec ); end; const MaxHeapAddr : LongWord = $7FFFFFFF; MaxHeapBlock : LongWord = $7FFFFFFF; MinHeapBlock : LongWord = 1; HeaderVHeap : string = 'HNV(C)VIRTUAL HEAP FILE V 1.0'; HeaderVFree : string = 'FREE BLOCKS LIST'; Init : Boolean = False; StructRPtr : Pointer = nil; StructVPtr : VirtualPtr = 0; UseFactor : LongWord = 0; DelFreeArea : LongWord = 0; VHeapOrg : LongWord = 0; {- begin of virtual heap -} VHeapPtr : LongWord = 0; {- end of heap -} Caching : Boolean = True; Cache : CacheAddr = nil; var OldExit : Pointer; FreeListArea : FreeListPtrV; F : file; FileName : string; function VString.Addr : StringPtr; begin if VAddr <> 0 then Addr := VirtualToPtr( VAddr ) else begin VAddr := GetVMem( Succ( SizeOf( string ) ) ); Addr := VirtualToPtr( VAddr ); end; end; procedure VString.Init; begin VAddr := 0; end; procedure VString.Free; begin FreeVMem( VAddr ); end; procedure VHeapError( S : string ); begin ShowMessage( S ); Halt( 1 ); end; procedure Abort( S : string ); begin {Inline( $FF/$1E/>VHeapErrorProc );} VHeapError( S ) end; function AllocateFreeList : Pointer; var i : Word; P : Pointer; begin GetMem( P, SizeOf( FreeListVHeap ) ); with FreeListPtrV( P )^ do begin NFree := 0; for i := 1 to MaxFree do begin FreeL[ i ].Len := 0; FreeL[ i ].Addr := 0; end; end; AllocateFreeList := P; end; procedure Store( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheWrite ); VHeapOk := True; Seek( F, VR.Addr ); BlockWrite( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure Load( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheRead ); VHeapOk := True; Seek( F, VR.Addr ); BlockRead( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure LoSwapProc( var P : Pointer; V1, V2 : VirtualPtr ); var VR1 : VirtualPtrRec Absolute V1; VR2 : VirtualPtrRec Absolute V2; begin if P <> nil then begin Store( P^, V1 ); FreeMem( P, VR1.Len ); end; if not VHeapOk then exit; GetMem( P, VR2.Len ); Load( P^, V2 ); end; function LoCacheProc( V : VirtualPtr ) : Pointer; begin VHeapOk := True; if StructVPtr <> V then begin LoSwapProc( StructRPtr, StructVPtr, V ); LoCacheProc := StructRPtr; end else LoCacheProc := StructRPtr; end; procedure CacheNormalizing( L : LongWord ); {--------------------------------------} { Normalizing of Cache size to L value } {--------------------------------------} var P, T : CacheAddr; Done : Boolean; begin repeat P := Cache; T := P; Done := True; while ( BytesInCache + L > MaxCacheSize ) and ( P <> nil ) do with P^ do if Next = nil then begin Store( RecA^, HAddr ); Dec( BytesInCache, VRec.Len ); { Decrement Cache length } if CacheLevel 'INSSUFICIENT MEMORY FOR CACHING.' ); WriteLn( 'PROGRAM TERMINATED.' ); Abort( '$16 CRITICAL ERROR.' ); end; Dec( CacheLevel ); { Decrement Cache level } FreeMem( RecA, VRec.Len ); { Dispose structure } if T <> P then T^.Next := nil { goto next Cache record } else Cache := nil; FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } P := nil; Done := False; end else begin T := P; P := Next; end; until Done; end; function AddRecToCache( V : VirtualPtr ) : Pointer; { addition new Cache record to Cache structure } var P : CacheAddr; VR : VirtualPtrRec Absolute V; begin GetMem( P, SizeOf( CacheRec ) ); with P^ do begin Next := Cache; Cache := P; GetMem( RecA, VR.Len ); Inc( CacheLevel ); {- -} Load( RecA^, V ); Inc( BytesInCache, VR.Len ); HAddr := V; AddRecToCache := RecA; end; end; procedure DelCacheRec( V : VirtualPtr ); { deleting Cache record from Cache structure. uses in FreeVmem } var P, T : CacheAddr; begin if not Caching then { exit if Caching is not active } exit; { search a virtual heap pointer in Cache structure } P := Cache; T := P; while P <> nil do with P^ do if HAddr = V then begin Dec( BytesInCache, VRec.Len ); { Decrement Cache length } FreeMem( RecA, VRec.Len ); { Dispose this structure } if T <> P then T^.Next := P^.Next { go to next Cache record } else Cache := P^.Next; { go to next Cache record } FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } exit; end else begin T := P; P := Next; end; end; {-------------------------------------------------------} { Center function of VHeapLow unit } { converted a virtual heap pointer to real heap pointer } {-------------------------------------------------------} function VirtualToPtr( V : VirtualPtr ) : Pointer; var P, T : CacheAddr; VR : VirtualPtrRec Absolute V; begin Inc( CacheSearch ); if ( VR.Addr < VHeapOrg ) or ( VR.Addr + VR.Len > VHeapPtr ) then Abort( '$46 Invalid virtual pointer.' ); P := Cache; T := P; while P <> nil do if P^.HAddr = V then begin {- Set top of cache -} if T <> P then begin T^.Next := P^.Next; P^.Next := Cache; Cache := P; end; VirtualToPtr := P^.RecA; Inc( CacheHits ); exit; end else begin T := P; P := P^.Next; end; CacheNormalizing( VR.Len ); VirtualToPtr := AddRecToCache( V ); end; function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to string pointer -} begin StrVptr := VirtualToPtr( V ); end; procedure FlushOldRec; begin if StructRPtr <> nil then Store( StructRPtr^, StructVPtr ); end; procedure SetCaching( TF : Boolean ); {- turn Caching OFF if TF is false -} begin end; function ReadLongWord( var F : file ) : LongWord; var L : LongWord; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$0B initialization error.' ); ReadLongWord := L; end; function ReadString( var F : file ) : string; var i : LongWord; S : string; begin VHeapOK := True; ReadString := ''; i := ReadLongWord( F ); ShowMessage( intToStr( i ) ); SetLength( S, i ); BlockRead( F, S[ 1 ], i, i ); if i <> Length( S ) then Abort( '$0A Initialization Error.' ); ReadString := S; end; function ReadVirtualPtr( var F : file ) : VirtualPtr; var L : VirtualPtr; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$13 initialization error.' ); ReadVirtualPtr := L; end; function ReadBoolean( var F : file ) : Boolean; var L : Boolean; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$0D initialization error.' ); ReadBoolean := L; end; procedure WriteLongWord( var F : file; L : LongWord ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$10 initialization error.' ); end; procedure WriteString( var F : file; S : string ); var i : LongWord; begin VHeapOK := True; WriteLongWord( F, Length( S ) ); BlockWrite( F, S[ 1 ], Length( S ), i ); if i <> Length( S ) then Abort( '$0F Initialization Error.' ); end; procedure WriteVirtualPtr( var F : file; L : VirtualPtr ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$12 initialization error.' ); end; procedure WriteBoolean( var F : file; L : Boolean ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$11 initialization error.' ); end; procedure StoreHeader; begin Seek( F, 0 ); WriteString( F, HeaderVHeap ); WriteLongWord( F, UseFactor ); WriteLongWord( F, DelFreeArea ); WriteLongWord( F, VHeapOrg ); WriteLongWord( F, VHeapPtr ); end; procedure StoreBase; var i : Word; begin for i := 0 to 11 do WriteVirtualPtr( F, BaseAddr[ i ] ); end; procedure StoreFreeList; var i : Word; begin WriteString( F, HeaderVFree ); WriteLongWord( F, FreeListArea^.NFree ); for i := 1 to MaxFree do WriteVirtualPtr( F, FreeListArea^.FreeV[ i ] ); end; procedure LoadHeader; begin Seek( F, 0 ); HeaderVHeap := ReadString( F ); UseFactor := ReadLongWord( F ); DelFreeArea := ReadLongWord( F ); VHeapOrg := ReadLongWord( F ); VHeapPtr := ReadLongWord( F ); end; procedure LoadBase; var i : Word; begin for i := 0 to 11 do BaseAddr[ i ] := ReadVirtualPtr( F ); end; procedure LoadFreeList; var i : Word; begin if ReadString( F ) <> HeaderVFree then Abort( '$32 file is not Virtual Heap' ); FreeListArea^.NFree := ReadLongWord( F ); for i := 1 to MaxFree do FreeListArea^.FreeV[ i ] := ReadVirtualPtr( F ); end; function HasExtension( Name : string; var DotPos : Word ) : Boolean; {-Return whether and position of extension separator dot in a pathname} var I : Word; begin DotPos := 0; for I := Length( Name ) downto 1 do if ( Name[ I ] = '.' ) and ( DotPos = 0 ) then DotPos := I; HasExtension := ( DotPos > 0 ) and ( Pos( '\', Copy( Name, Succ( DotPos ), 64 ) ) = 0 ); end; function ForceExtension( Name, Ext : string ) : string; {-Return a pathname with the specified extension attached} var DotPos : Word; begin if HasExtension( Name, DotPos ) then ForceExtension := Copy( Name, 1, DotPos ) + Ext else ForceExtension := Name + '.' + Ext; end; procedure MakeNewVHeap; var i : Word; begin StoreHeader; for i := 0 to 11 do begin BaseAddr[ i ] := 0; end; StoreBase; FreeListArea^.NFree := 0; StoreFreeList; VHeapOrg := FilePos( F ); VHeapPtr := VHeapOrg; StoreHeader; end; procedure VHeapExit; begin if SaveVHeap then begin if Caching then begin CacheNormalizing( MaxCacheSize ); if Cache <> nil then WriteLn( ' Cache ERROR.' ); end else FlushOldRec; StoreHeader; StoreBase; StoreFreeList; Seek( F, VHeapPtr ); Truncate( F ); Close( F ); end else begin Close( F ); Erase( F ); end; end; { --------------------------- GetVmem --------------------------------} function GetVmemPrim( L : Word ) : VirtualPtr; var V : VirtualPtr; VR : VirtualPtrRec Absolute V; j : Word; K : LongWord; procedure SetVHeapPtr; begin VR.Len := L; VR.Addr := VHeapPtr; Inc( VHeapPtr, L ); end; function Hole : Word; var i : Word; begin Hole := 0; with FreeListArea^ do begin K := MaxHeapBlock; for i := 1 to NFree do if ( FreeL[ i ].Len >= L ) and ( ( FreeL[ i ].Len - L ) < K ) then begin K := FreeL[ i ].Len - L; Hole := i; end; end; end; begin with FreeListArea^ do if NFree = 0 then begin SetVHeapPtr; GetVmemPrim := V; exit; end else begin { Search of Minimum Heap Hole } j := Hole; if j <> 0 then begin VR.Len := L; VR.Addr := FreeL[ j ].Addr; Dec( FreeL[ j ].Len, L ); Inc( FreeL[ j ].Addr, L ); if FreeL[ j ].Len = 0 then begin FreeV[ j ] := FreeV[ NFree ]; Dec( NFree ); end; GetVmemPrim := V; exit; end; SetVHeapPtr; GetVmemPrim := V; end; end; function GetVmem( L : Word ) : VirtualPtr; var V : VirtualPtr; P : ^Byte; begin VHeapOk := True; V := GetVmemPrim( L ); GetMem( P, L ); Store( P^, V ); Freemem( P ); if not VHeapOk then GetVmem := VHeapPtr else GetVmem := V; Dec( MaxHeapSpace, L ); end; { --------------------------- GetVmem --------------------------------} { --------------------------- FreeVmem --------------------------------} procedure SortFreeListByAddress; procedure Sort( l, r : Word ); var i, j : Word; x : LongWord; y : VirtualPtr; begin with FreeListArea^ do begin i := l; j := r; x := FreeL[ ( l + r ) div 2 ].Addr; repeat while FreeL[ i ].Addr < x do i := i + 1; while x < FreeL[ j ].Addr do j := j - 1; if i j; if l < j then sort( l, j ); if i < r then sort( i, r ); end; end; begin {quicksort} ; sort( 1, FreeListArea^.NFree ); end; function ReorgFreeList : Boolean; var Q : LongWord; i : Word; begin ReorgFreeList := False; with FreeListArea^ do begin if NFree MaxHeapBlock then exit; Inc( FreeL[ i ].Len, FreeL[ i + 1 ].Len ); FreeV[ i + 1 ] := FreeV[ NFree ]; Dec( NFree ); ReorgFreeList := True; exit; end; end; end; procedure FreeVmem( V : VirtualPtr ); { Erased a virtual heap pointer } var VR : VirtualPtrRec Absolute V; i : Word; K, j : Word; begin DelCacheRec( V ); { free real heap space if Caching is active } with FreeListArea^ do begin if ( VR.Addr + VR.Len ) <> VHeapPtr then begin if ( NFree + 1 ) > MaxFree then begin K := MaxHeapBlock; j := 1; for i := 1 to MaxFree do if FreeL[ i ].Len < K then begin K := FreeL[ i ].Len; j := i; end; FreeV[ j ] := V; end else begin Inc( NFree ); FreeV[ NFree ] := V; end; end else Dec( VHeapPtr, VR.Len ); repeat if NFree > 1 then SortFreeListByAddress; until not ReorgFreeList; end; end; function StructToVHeap( var S; L : Word ) : VirtualPtr; var V : VirtualPtr; begin StructToVHeap := 0; VHeapOk := True; V := GetVMemPrim( L ); if not VHeapOk then exit; Store( S, V ); StructToVHeap := V; end; procedure StructFromVHeap( var S; V : VirtualPtr ); begin VHeapOk := True; Load( S, V ); end; function StringToVHeap( S : string ) : VirtualPtr; var V : VirtualPtr; begin StringToVHeap := 0; VHeapOk := True; V := GetVMemPrim( Length( S ) ); if not VHeapOk then exit; Store( S, V ); StringToVHeap := V; end; function StringFromVHeap( V : VirtualPtr ) : string; begin VHeapOk := True; StringFromVHeap := StringPtr( VirtualToPtr( V ) )^; end; procedure Statistics( ST : TStrings ); var i : Word; begin with FreeListArea^ do begin UseFactor := 0; if NFree > 0 then for i := 1 to NFree do UseFactor := UseFactor + FreeL[ i ].Len; end; Write( TPStr, '------------ VIRTUAL HEAP STATISTICS ---------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Heap --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Heap......................: ', VHeapPtr - VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Start Virtual Heap Address.........: ', VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes available to Virtual Heap....: ', MaxHeapSpace : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Holes --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Number of Heap Holes...............: ', FreeListArea^.NFree : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in accessible Heap Holes.....: ', UseFactor : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in not accessible Heap Holes.: ', DelFreeArea : 10, ' і' ); ST.Add( ReturnStr ); if ( VHeapPtr - VHeapOrg ) <> 0 then Write( TPStr, 'і Percent Holes in Heap..............: ', ( UseFactor + DelFreeArea ) / ( VHeapPtr - VHeapOrg + UseFactor ) * 100 : 8 : 4, ' % і' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Cache --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Cache.....................: ', BytesInCache : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і General Cache Space................: ', MaxCacheSize : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Cache Level........................: ', CacheLevel : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Disk Input : ', CacheRead : 10, '; Output : ', CacheWrite : 10, ' і' ); ST.Add( ReturnStr ); if CacheSearch <> 0 then Write( TPStr, 'і Cache Hits : ', CacheHits : 10, '; Eff [%] : ', CacheHits / CacheSearch * 100 : 10 : 3, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); end; procedure CalcDiskSize( FName : string ); begin if Pos( ':', FName ) <> 0 then MaxHeapSpace := DiskFree( Pos( UpCase( FName[ 1 ] ), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ) ) else MaxHeapSpace := DiskFree( 0 ); end; procedure InitVHeap( FName : string; Save : Boolean ); begin if Init then Abort( '$25 Double Initialization.' ); FileName := FName; SaveVHeap := Save; FreeListArea := AllocateFreeList; if CacheHeapRatio > 0.8 then CacheHeapRatio := 0.8; MaxCacheSize := Trunc( MaxHeapAddr * CacheHeapRatio ); Assign( F, FName ); if not FileExists( FName ) then begin Rewrite( F, 1 ); MakeNewVHeap; VHStatus := NewVHeap; CalcDiskSize( FName ); end else begin Reset( F, 1 ); VHStatus := OldVHeap; if ReadString( F ) <> HeaderVHeap then Abort( 'file is not Virtual Heap.' ); LoadHeader; LoadBase; LoadFreeList; Init := True; CalcDiskSize( FName ); end; end; initialization finalization VHeapExit; end. |
| Для данного материала нет комментариев. |
Модули для рисования математических формул
| игорьев, дата публикации 27 ноября 2002г. |
Модули ExprDraw и ExprMake служат для рисования математических формул.
Модуль ExprDraw содержит классы, использующиеся для отображения формул. Эти классы описаны в файле .
Создание и установление взаимосвязей между классами, описанными в модуле ExprDraw, для отображения конкретной формулы - занятие трудоёмкое, поэтому для его автоматизации создан модуль ExprMake, который создаёт классы на основании символьной записи формулы. Описание модуля находится в файле .
Описание языка, на котором описываются формулы, вынесено в программу ExprGuide, которая содержится в архиве как в откомпилированном варианте, так и в виде исходных кодов. В левой части окна программы находится список всех конструкций языка. При выборе одного из элементов списка в правой части окна отображается описание и пример использования данной конструкции. Кнопка "Печать" позволяет вывести на принтер описание всех конструкций языка с примерами.
Модули ExprDraw и ExprMake поставляются "as is", в том виде, в каком я сам их использую. Первоначально я разрабатывал их исключительно для личного пользования, но потом решил поделиться. Возможности модулей позволяют отображать очень большой спектр формул. В математическом справочнике Бронштейна и Семендяева мне не удалось найти ни одной формулы, которая была бы модулям "не по зубам". Такие формулы есть в некоторых томах "Курса теоретической физики" Ландау и Лифшица, но это связано исключительно с использованием тических и прочих непонятных букв, все остальные конструкции (включая постоянную Планка и лямбду с чертой) модули отображают без проблем. С одним замечанием: моё личное предпочтение - использование для обозначения векторов стрелки над символом, а не жирного шрифта, поэтому модули поддерживают именно стрелку. Текст модулей практически не содержит комментариев, все комментарии вынесены в файлы и . Эти комментарии далеки от полноты, поэтому тем, кто захочет не только использовать готовую библиотеку, но и изменить что-то в ней, придётся серьёзно поработать, чтобы разобраться в коде.
Модули написаны на Delphi 5, испытаны в Windows 95 OSR 2.1, Windows NT 4.0 SP6 Workstation, Windows 2000 Advanced Server. По идее, ничего не мешает использовать эти модули и в других версиях Delphi, так как они поставляются в исходных кодах. Никакой специальной установки модулей не нужно, просто поместите файлы ExprDraw.pas и ExprMake.pas в один из тех каталогов, в которых Delphi ищет библиотеки, и добавьте ExprDraw и ExprMake в раздел uses своего модуля.
Просьба всем тем, кто будет использовать модули в своих программах, найти в About Box'е или ещё где-нибудь место для фразы типа "Для отображения математических формул используются модули ExprDraw и ExprMake, разработанные Григорьевым Антоном, e-mail."
По этому же адресу можно высылать мне замечания, информацию об ошибках в модулях и предложениях.
Скачать библиотеку: (278 K)
дата обновления 04.12.02 — решена проблема работы модулей под Windows 98/ME
Убедительная просьба НЕ ПОСЫЛАТЬ мне писем следующих типов:
,
Черноголовка, 27.11.02
Специально для
Набор функций для создания диалоговых окон в стиле диалогов помощника MSOffice 2000.
| Раздел Сокровищница | рь Шевченко, дата публикации 26 апреля 2002г. |
Каждое диалоговое окно можно ассоциировать с Control'ом (хвостик диалога будет указывать на Control), если параметр Control не указан или равен nil, то хвостик в диалогах появляться не будет, и диалог будет размещен по центру главной формы приложения.
Имеется ряд глобальных переменных, действующих на внешний вид всех диалогов:
В (11.8K) содержатся unit's для диалогов и тестовый пример.
Любая критика, предложения и пожелания принимаются :-)
С уважением,
Набор классов для работы с журналом событий в WinNT/2000/XP.
| Раздел Сокровищница |
Класс TDLLCache. Предназначен для хранения списка загруженных динамических библиотек, используемых при формировании текстов сообщений при расшифровке записей журнала событий.
Используется внутри класса TEventLogRecordDecoder.
Методы:
function LoadLibrary( const Name : string; FLags : DWORD ) : HInstance; загружает библиотеку и возвращает ее описатель. procedure UnloadLibrary( const Name : string ); выгружает библиотеку. procedure UnloadAll; выгружает все загруженные библиотеки. Класс TEventLogRecordDecoder. Предназначен для расшифровки данных записи журнала событий. Большинство свойств соответствуют полям структуры EVENTLOGRECORD. Их подробное описание есть в справке и MSDN.
Методы:
constructor Create( const ALogName : string ); ALogName имя журнала. Должно соответствовыть имени одного из подключей ключа HKLM\SYSTEM\CurrentControlSet\Services\Eventlog реестра, обычно Application, System и Security. Это имя можно также задать при помощи свойства LogName. procedure Reset; - выгружает все загруженные при расшифровке динамические библиотеки. procedure GetRawData(Stream : TStream); Сохраняет в поток Stream двоичные данные, содержащиеся в записи о событии. Указатель на этот блок данных можно получить также из свойства Data, а длину - из DataLength. procedure GetRawRecord(Stream : TStream); Сохраняет в поток Stream содержимое записи журнала целиком. procedure ValidateRecord; Выполняет проверку формата записи, и если она не соответствует формату, возбуждает исключение EInvalidEventLogRecord.
Свойства:
property RecPtr : PEVENTLOGRECORD read FRecPtr write FRecPtr; Предназначено для задания указателя на структуру EVENTLOGRECORD, данные которой нужно прочитать. property LogName : string read FLogName write FLogName; Предназначено для задания имени журнала. Класс TEventLog
Методы:
procedure Open; Открывает журнал событий, заданный свойством LogName. procedure OpenBackup( const BackupName : string ); Открывает резервную копию журнала. procedure Close; Закрывает журнал событий procedure Clear( const BackupName : string = '' ); Очищает журнал событий. Журнал должен быть открыт. Если задан параметр BackupName, то создается резервная копия журнала. procedure Backup( const BackupName : string ); Создает резервную копию журнала. function CreateIterator( Direction : TLogIterateDirection=idBackward) : TEventLogIterator; Создает и возвращает итератор, связанный с данным экземпляром класса TEventLog.
Свойства:
property Active : boolean read GetActive write SetActive; Показывает открыт или закрыт журнал. property Count : DWORD read GetCount; Количество записей в журнале property Handle : THandle read FHandle; Описатель открытого журнала. property LogName : string read FLogName write SetLogName; Задает имя журнала. property OldestRecord : DWORD read GetOldestRecord; Номер самой старой записи в журнале. property RegKey : string read GetRegKey; Имя корневого ключа реестра для выбранного журнала. Класс TEventLogIterator Предназначен для перемещения по открытому журналу сообщений, предоставляет доступ к текущей записи.
Методы:
constructor Create( AEventLog : TEventLog; ADirection : TLogIterateDirection ); AEventLog - Экземпляр класса TEventLog, для которого создается итератор ADirection - задает направление прохода по журналу. function IsEmpty : boolean; Возвращает true если журнал пуст. procedure Reset; Сбрасывает текущее состояние итератора и переходит, в зависимости от заданного направления обхода, к первой или последней записи в журнале. Вызов Reset необходим, например, в том случае, если было изменено имя журнала в соответствующем экземпляре класса TEventLog. function IsDone : boolean; function Next : boolean; Переход к следующей записи в журнале в соответствие с выбранным направлением обхода. function Seek( Number : DWORD ) : boolean; Переход к записи журнала с заданным номером.
свойства:
property Current : TEventLogRecordDecoder read GetCurrent; Дает доступ к текущей записи журнала. property EventLog : TEventLog read FEventLog write SetEventLog; Экземпляр класса TEventLog, с которой связан с данным экземпляром итератора. property Direction : TLogIterateDirection read FDirection write SetDirection; Направление, в котором идет перемещение по журналу при вызове Next.
Примечание:
при написании использовались модули из библиотеки Jedi WinAPI Library (JWA).
Библиотеку можно найти здесь
Скачать пример, иллюстрирующий работу классов: (10.7K)
Ссылки по теме:
Наследник TComboBox, показывающий Hint для строки в ListBox'овой части, не видимой целиком.
| Раздел Сокровищница | рь Шевченко, дата публикации 17 апреля 2002г. |
| Ограничения: Компонент проверялся при работе с значением Style: csDropDown, csDropDownList. при остальных значениях работа не гарантируется :-) Компонент не тестировался в режиме design-time. История изменений: 16.04.2002 Исправлено поведение при закрытии, когда показан hint и ComboBox закрывается по клавише Enter, Escape или F4. Теперь hint убирается. Добавлено свойство HorizontalExtent, позволяющее устанавливать горизонтальный Scrollbar в списке ComboBox'a. По умолчанию свойство имеет значение -1, что запрещает установку горизонтального ScrollBar'а. |  |
Скачать компонент (5 K)
Настройка DCOM при помощи DCOMCNFG.EXE
Закладка DefaultProperties| Элемент | Значение | 9x | NT |
| Enable Distributed COM on this computer | True | + | + |
| Enable COM Internet Services on this computer | Не имеет значения | - | + |
| Default Authentication Level | None | + | + |
| Default Impersonation Level | Impersonate | + | + |
| Provide additional security for reference tracking | False | + | + |
Закладка DefaultSecurity
| Элемент | Значение | 9x | NT |
| Enable remote connection | True | + | - |
| Default access permissions | Everyone = allow access | - | + |
| Default access permissions | The world = grant access | + | - |
| Default launch permissions | Everyone = allow launch | - | + |
Закладка Applications Позиционироваться на сервер.exe. Кнопка "Properties..."
Закладка Location
| Элемент | Значение | 9x | NT |
| Run application on the computer where the data is located | False | + | + |
| Run application on this computer | True | + | + |
| Run application on the following computer | False | + | + |
Закладка Security
| Элемент | Значение | 9x | NT |
| Use default access permissions | True | + | + |
| Use default launch permissions | True | - | + |
| Use custom configuration permissions | False | - | + |
Закладка Identity
| Элемент | Значение | 9x | NT |
| Which user account do you want to use to run this application | The interactive user | - | + |
Несколько функций для работы со списками
Добавление группы в список TListViewprocedure AddToListView(LV: TListView; Par: array of string); var NI : TListItem; i: integer; begin NI := LV.Items.Add; NI.Caption := Par[Low(Par)]; for i := 1 to (High(Par) - Low(Par)) do NI.SubItems.Append(Par[i]); end;
Удаление элемента из листа TList.
Достаточно универсальна, хотя требуется не так часто. procedure RemovePtrFromList(L: TList; P: pointer); var i: integer; begin if not Assigned(L) then Exit; i := L.IndexOf(P); if i >= 0 then L.Delete(i); end;
Добавить объект в список, если такого еще нет.
procedure IncludePtrToList(L: TList; P: pointer); var i: integer; begin if not Assigned(L) then Exit; i := L.IndexOf(P); if i < 0 then L.Add(P); end;
Алексей Еремеев
Но к делу
Взявшись оформлять этот пример для общественности, я понял, что меняются не только времена и люди, но и исходники лежащие в архиве. Да их не узнать! Да неужели это писал я? Да... точно... странно... Но ведь он все еще работает! Вдвойне странно... Так что если что - сильно не ругаться - я был молодой и временами делал некрасивости. Старинный закон гласит: последняя ошибка программы выявляется через 7 лет эксплуатации. Если вы заметили ошибку, которой не заметил я - то буду благодарен, если вы мне о ней напишите. Я, пожалуй, не буду следовать примеру Д. Кнута и высылать деньги за замеченные ошибки, но спасибо скажу :).О компоненте TListView
В этом компоненте есть один недостаток - нет обычный средств для того, чтобы определить редактируется ли в данный момент один из пунктов этого компонента. Например в компоненте TStringGrid есть для этого свойство EditorMode. А тут вообще ничего нету. Поэтому, кстати, в прошлой версии программы производилась очень кривая проверка на этот счет. Я все-таки нашел как это можно узнать. Естественно на помощь приходит Api Windows. Там есть такая функция: ListView_GetEditControl, в качестве параметра которой нужно указать дескриптор окна TListView. Эта функция возвращает дескриптор компонента, в котором происходит редактирование пункта компонента TListView. Если же компонент не редактируется, то она возвращает ноль. Но это все описывается в справочной системе. Плюс там еще есть куча полезный функций этого же типа с соответствующими сообщениями, которые возможно будут полезны. Но большая их часть, конечно, реализована в компоненте TListView обычными дельфивскими методами или свойствами. Я на всякий случай приведу их полный список: LVM_ARRANGE ListView_Arrange LVM_CREATEDRAGIMAGE ListView_CreateDragImage LVM_DELETEALLITEMS ListView_DeleteAllItems LVM_DELETECOLUMN ListView_DeleteColumn LVM_DELETEITEM ListView_DeleteItem LVM_EDITLABEL ListView_EditLabel LVM_ENSUREVISIBLE ListView_EnsureVisible LVM_FINDITEM ListView_FindItem LVM_GETBKCOLOR ListView_GetBkColor LVM_GETCALLBACKMASK ListView_GetCallbackMask LVM_GETCOLUMN ListView_GetColumn LVM_GETCOLUMNWIDTH ListView_GetColumnWidth LVM_GETCOUNTPERPAGE ListView_GetCountPerPage LVM_GETEDITCONTROL ListView_GetEditControl LVM_GETIMAGELIST ListView_GetImageList LVM_GETISEARCHSTRING ListView_GetISearchString LVM_GETITEM ListView_GetItem LVM_GETITEMCOUNT ListView_GetItemCount LVM_GETITEMPOSITION ListView_GetItemPosition LVM_GETITEMRECT ListView_GetItemRect LVM_GETITEMSPACING ListView_GetItemSpacing LVM_GETITEMSTATE ListView_GetItemState LVM_GETITEMTEXT ListView_GetItemText LVM_GETNEXTITEM ListView_GetNextItem LVM_GETORIGIN ListView_GetOrigin LVM_GETSELECTEDCOUNT ListView_GetSelectedCount LVM_GETSTRINGWIDTH ListView_GetStringWidth LVM_GETTEXTBKCOLOR ListView_GetTextBkColor LVM_GETTEXTCOLOR ListView_GetTextColor LVM_GETTOPINDEX ListView_GetTopIndex LVM_GETVIEWRECT ListView_GetViewRect LVM_HITTEST ListView_HitTest LVM_INSERTCOLUMN ListView_InsertColumn LVM_INSERTITEM ListView_InsertItem LVM_REDRAWITEMS ListView_RedrawItems LVM_SCROLL ListView_Scroll LVM_SETBKCOLOR ListView_SetBkColor LVM_SETCALLBACKMASK ListView_SetCallbackMask LVM_SETCOLUMN ListView_SetColumn LVM_SETCOLUMNWIDTH ListView_SetColumnWidth LVM_SETIMAGELIST ListView_SetImageList LVM_SETITEM ListView_SetItem LVM_SETITEMCOUNT ListView_SetItemCount LVM_SETITEMPOSITION ListView_SetItemPosition LVM_SETITEMPOSITION32 ListView_SetItemPosition32 LVM_SETITEMSTATE ListView_SetItemState LVM_SETITEMTEXT ListView_SetItemText LVM_SETTEXTBKCOLOR ListView_SetTextBkColor LVM_SETTEXTCOLOR ListView_SetTextColor LVM_SORTITEMS ListView_SortItems LVM_UPDATE ListView_UpdateСкачать:
О назначении пользовательского TNotifyEvent
| Раздел Сокровищница | ний Колеватов, дата публикации 14 мая 2002г. |
Динамическое назначение вашей процедуры на событие, может быть полезно при динамическом создании компонентов или создании плагинов живущих в dll
Все просто стоит только обратить внимание что определение TNotifyEvent = procedure(Sender: TObject) of object; а сие значит что These types represent method pointers. A method pointer is really a pair of pointers; the first stores the address of a method, and the second stores a reference to the object the method belongs to. Given the declarations (Delphi help :)) главное не забыть что при обьявлении процедуры надо указать пару указателей procedure MyProcOnClick(P1,P2 :pointer); begin if P2<>nil then Showmessage(TComponent(P2).Name); end; procedure TForm1.Button1Click(Sender: TObject); begin @Button2.OnClick := @MyProcOnClick; end; Вот и все теперь при нажатии на кнопку два выполниться процедура MyProcOnClick, P2 указывает на обьект Button2
Аналогичная проблема может быть решена
2. Аналогичная проблема может быть решена для StringGrid. Привожу пример обработчика события OnDrawCell. Он выводит нестандартно во все ячейки, а ячейку, координаты которой совпадают с внешними параметрами SgKritCol, SgKritRow, красит желтым цветом. Пример фрагмента сетки StringGrid показан на Рисунок 2.
| procedure TfAg.SgKritDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var r: TRect; begin With Sender as TStringGrid do begin With Canvas do begin if (SgKritCol = ACol) and (SgKritRow = ARow) then Brush.Color:= clYellow else Brush.Color := clWhite; Font.Color:= clBlack; FillRect(Rect); end; r:= KdnRect(Rect,0,4,-3,0); DrawText(Canvas.Handle, PChar(SgKrit.Cells[ACol, ARow]), Length(SgKrit.Cells[ACol, ARow]),r, DrawTextBiDiModeFlags(DT_RIGHT)); end; end; |
Рисунок 2. Фрагмент StringGrid с нестандартной закраской ячейки и форматированием ее содержимого по правому краю и по высоте ячейки
Коднянко Владимир
Красноярск, 17.05.2002
Смотрите по теме:
О нестандартном выводе в DBGrid и StringGrid
| Раздел Сокровищница |
1. Во многих FAQ-ах и книгах по Delphi приходилось видеть процедуры нестандартной закраски отдельных ячеек DBGrid. Однако при их исполнении текст отформатирован по левому краю и располагается по высоте ячейки не так, как в ячейках стандартного вывода. Ниже привожу пример обработчика события OnDrawColumnCell для сетки gAg: TDBGrid, где эти проблемы сняты для случая форматирования по правому краю:
| procedure TfAg.gAgDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var r: TRect; begin With gAg.Canvas do begin if not (gdFocused in State) and (Column.Field.AsString = '-1') and (Column.FieldName = 'PointN') then begin Brush.Color:= clRed; // цвет подложки - красный Font.Color:= clWhite; // цвет символов - белый FillRect(Rect); // закраска всей ячейки With Sender as TDBGrid do begin r:= KdnRect(Rect,0,2,-3,0); //уменьшенный и смещенный Rect //нестандартный вывод DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text),r, DrawTextBiDiModeFlags(DT_RIGHT)); end; end else // стандартный вывод gAg.DefaultDrawColumnCell(Rect, DataCol, Column, State); end; end; |
На Рисунок 1 приведен фрагмент сетки, сформированной этим обработчиком.
Рисунок 1. Фрагмент DBGrid с нестандартной закраской отдельных ячеек и форматированием их содержимого по правому краю и по высоте ячейки
Процедура выводит нестандартно только значения -1 в ячейки столбеца PointN сетки fAg. Суть состоит в использовании уменьшенного Rect-а, сформированного по базовому Rect с помощью функции KdnRect (текст приведен ниже) с последующей подгонкой уменьшенного Rect-а под формат стандартного вывода и рисованием содержимого ячейки по нужному формату выравнивания. Так, уменьшенный r смещен по отношению к Rect вниз на 2 (2), правая граница смещена влево на 3 (-3). Константа DT_RIGHT указывает на способ форматирования. Для того, чтобы вывести текст в центре ячейки следует константу DT_RIGHT заменить на DT_CENTER. При этом оператор формирования r лучше заменить на r:= KdnRect(Rect,0,2,0,0) с целью использования всей ширины ячейки.
| function KdnRect(Rect: TRect; DLeft,DTop,DRight,DBottom: Integer): TRect; begin With Result do begin Left:= Rect.Left + DLeft; Top:= Rect.Top + DTop; Right:= Rect.Right + DRight; Bottom:= Rect.Bottom + DBottom; end; end; |
Обмен текстовой информацией между модулями проекта
| й Перовский, дата публикации 20 февраля 2003г. |
При написании программ я всегда старался четко отделять пользовательский интерфейс от алгоритма задачи.
С появленинием в Delphi ActionList'а стало гораздо проще писать алгоритмическую часть без оглядки на структуру пользовательского интерфейса.
Но осталась проблема отображения информации: в некоторой точке программы требуется вывести сообщение, а куда выводить неизвестно.
Разработчик интерфейса еще не решил, что выводить в StatusBar, что в MessageBox. Какую отладочную информацию поместить в логфайл. Я решаю эту проблему следующим образом — во всех существенных точках алгоритма вызывается процедура ToLog.
Два ее параметра определяют текст сообщения и ее предназначение. 256 "каналов" должны быть поделены между сообщениями об ошибках, отладочной информацией, информационными сообщениями и результатами.
Это единственное соглашение, которое должны соблюдать все участники проекта. Разработчик интерфейса решает для компонента - сообщения из каких каналов он должен отображать и регистрирует соответствующий объект (Log). "Расчетные" модули могут не ссылаться на модули с описанием форм и диалогов. Единственный модуль, через который они общаются - и на который обязаны ссылаться (причем в implementation разделе) это uLogs.
Модуль uLogs предназначен для передачи текстовых сообщений между различными модулями, визуальными компонентами и файлами. Для разделения сообщений различных типов введено 256 "каналов". Каждому сообщению должен быть сопоставлен номер канала, определяющий цель сообщения и технологию его обработки. Для протоколирования и/или визуализации сообщений предназначены специальные объекты "Логи" - наследники базового объекта TLog. Каждый "лог" может обрабатывать все сообщения из заданного множества каналов. Логи разных типов различаются способом фиксации или отображения информации.
В модуле описано 5 различных наследников абстрактного класса TLog. По их образцу легко создать классы для других способов обработки сообщений.
Обработка сообщений от мыши потомками собственного компонента
Проблема: имеем свой собственный компонент, который может содержать несколько объектов с собственным внешним видом, каждый из которых должен реагировать на перемещение мыши.Например -- подсвечиваться.
Для гуру: ничего интересного вы здесь не найдёте, примерчик это не более, чем пропаганда использования стандартного оконного механизма в противовес различным самоизобретённым велосипедам.
Классы: класс TMyControl -- основной компонент; TMySubControl -- класс того объекта, который будет лежать на TMyControl и подсвечиваться.
Наследование от TGraphicControl необязательно. Фактически, можно выбирать из четырёх вариантов: TControl базовый класс всех элементов управления, не имеет виндовского Handle(дескриптора) окна, т.е. данный элемент Windows не считает окном; вся реализация сообщений, отрисовки и пр. выполняется в VCL; (+) -- меньше кушает ресурсов, (-) -- см. TWinControl TGraphicControl то же, что и TControl, но имеет свойство Canvas, при помощи которого удобно рисовать и метод Paint, в котором надо рисовать TWinControl это полноценное Windows-окно со всеми преимуществами перед TControl: (а) может получать фокус ввода, (б) может содержать "детей" -- другие окна на своей поверхности, (в) -- имеет дескриптор, св-во Handle TCustomControl наследник TWinControl, отличия между ними те же, что и между TControl и TGraphicControl Выбран TGraphicControl по причине отсутствия "детей" и наличия Canvas.
Данные, составляющие компонент: FItem: TCollectionItem входит в какую-либо коллекцию и, собственно, содержат смысловое наполнение элемента. Я встречал вариант, когда у TMyControl не определялись "дети", а в качестве реакции на WM_PAINT перебирались элементы некоторой коллекции, которые кроме смысловых данных хранили свой контур, координаты и пр. и ручками всё это рисовалось... Жуть! Собственно, мой пример -- антиреклама описанного подхода
Скачать файл (3K)
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Buttons, ComCtrls; type TMySubControl = class(TGraphicControl) private FSelected: Boolean; //флаг, отмечающий подсвеченность FItem: TCollectionItem; procedure SetMouseOver(Val: Boolean); procedure MsMove(var M: TWMMouseMove); message WM_MOUSEMOVE; { Реакция на перемещение мыши } protected procedure Paint(); override; //по этому сообщению надо перерисовывать public constructor Create(AOwner: TComponent); override; destructor Destroy(); override; property IsSelected: Boolean read FSelected write SetMouseOver; { Свойство, отмечащее факт "подсвеченности" } end; { "Главный" элемент управления. Собственную процедуру отрисовки я не определял, а "дети" есть. Поэтому -- TWinControl } TMyControl = class(TWinControl) private procedure MsMove(var M: TWMMouseMove); message WM_MOUSEMOVE; public constructor Create(AOwner: TComponent); override; end; { Класс основной формы. Ничего интересного } TMain = class(TForm) CloseButt: TBitBtn; Label1: TLabel; Label2: TLabel; procedure CloseWndExecute(Sender: TObject); procedure FormCreate(Sender: TObject); private public end; var Main: TMain; implementation {$R *.DFM} { По кнопочке "Закрыть" } procedure TMain.CloseWndExecute(Sender: TObject); begin Close(); end; { Создание элементов вручную. Главное: вызвать конструктор, задать размеры и положение, назначить "родителя". Поскольку пакеты не используются, то на автомате создать их не выйдет. } procedure TMain.FormCreate(Sender: TObject); var c: TMyControl; begin c := TMyControl.Create(Self); with c do begin SetBounds(8, 8, 240, 180); Color := clTeal; Parent := Self; //"родитель" -- формочка end; with TMySubControl.Create(Self) do begin SetBounds(3, 7, 49, 11); Parent := c; //у всех TMySubControl родитель -- TMyControl end; with TMySubControl.Create(Self) do begin SetBounds(140, 53, 94, 25); Parent := c; end; with TMySubControl.Create(Self) do begin SetBounds(38, 100, 88, 70); Parent := c; end; end; { Мониторинг перемещений мыши по основному control-у. Отметьте, что когда курсор над "детьми", control не получает данное сообщение. } procedure TMyControl.MsMove(var M: TWMMouseMove); begin inherited; Main.Label1.Caption := Format('%d:%d', [M.XPos, M.YPos]); end; { Добавляем стиль 3D-рамки. Её отрисовка производится стандартными средствами винды. } constructor TMyControl.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csFramed]; end; { Перерисовка. Простой прямоугольник. Цвет -- стандартный или подсвеченный, в зависимости от IsSelected } procedure TMySubControl.Paint(); const a: array[Boolean] of TColor = (clWindow, clHighlight); begin inherited; Canvas.Brush.Color := a[IsSelected]; Canvas.FillRect(Canvas.ClipRect); with Canvas.ClipRect do //показываем -- какая именно часть перерисовывается Main.Label2.Caption := Format('(%d:%d) - (%d:%d)', [Left, Top, Right, Bottom]); end; { Смена значения свойства. Только один из TMySubControl может быть подсвеченным } procedure TMySubControl.SetMouseOver(Val: Boolean); var i: Integer; begin if Val <> FSelected then begin Invalidate(); //если изменилась подсветка, то надо перерисоваться if Val then //нас подсветили (Val = TRUE) for i := Parent.ControlCount - 1 downto 0 do //среди "братьев" ищем другие TMySubControl и снимаем им подсветку if (Parent.Controls[i] <> Self) and (Parent.Controls[i] is TMySubControl) then TMySubControl(Parent.Controls[i]).IsSelected := FALSE; FSelected := Val; end; end; procedure TMySubControl.MsMove(var M: TWMMouseMove); begin IsSelected := TRUE; //над нами переместили мышку -- значит подсветили end; constructor TMySubControl.Create(AOwner: TComponent); begin inherited; FItem := TCollectionItem.Create(nil {тут произвольный объект-коллекция, например его можно указать в параметрах конструктора}); end; destructor TMySubControl.Destroy(); begin FItem.Free(); inherited; end; end.
Общее
В прошлой статье я подробно описал программу, все ее возможности сохранились в полной мере и сейчас, появилось только несколько нововведений. Когда программа требует ввести какое-либо значение его можно вводить как угодно. То есть можно вводить любой сивол (в старой программе это тожно можно было сделать, но не во всех компонентах). Если он будет неправильным (нечисловой величиной), то она преобразуется в соответствующий Ansi код. В окне просмотра в компоненте ViewGrid в десятеричном режиме можно вводить любые тесковые символы, т.е. по сути писать текст, если надо. Плюс в этом же компоненте слева появился новый столбик в котором отображается адрес ближайшей к нему ячейки. Плюс некоторые мелкие доработки, как автоматическая фокусировка выбранной в ячейке в компоненте ViewGrid и т.д. Также в компонентах DataGrid и ListView (через точку с запятой) тоже можно также вводить произвольные значения. В форме просмотра появились компоненты типа TEdit в которых отображается текущая величина выбранно ячейки. Эти компоненты представляют собой числа величинами 8, 16, 32 бита в знаковом и беззнаковом вариантах. Чтобы изменить значения в ячейке, можно вводить данные прямо в соответствующий компонент типа TEdit.Ограничения текущей версии
В ситуациях, когда входному выражению соответствует обратная польская запись вида: a b c d e f g h i + + + + + + + + , где число подряд идущих переменных больше восьми, а также в некоторых других неудачных случаях, модуль откажется генерировать код функции.Это связано с использованием при вычислениях одного лишь стека сопроцессора для хранения промежуточных результатов, и будет исправлено в следующей версии.
Кроме того, для нормальной работы придется отключить Tools/Debugger options/Language Exceptions/Stop on Delphi Exceptions, иначе будет довольно утомительно: при анализе исключения возникают десятками.
Описание программы "Репликатор"
Определение установленных версий .NET Framework в системе
Определение установленных версий .NET Framework в системе. Пример на Delphi.
| /// |
| Для данного материала нет комментариев. |
Ошибка в процедуре _AddRefArray в Delphi 5 и ее исправление
| Мотов, дата публикации 10 января 2003г. |
Эта ошибка была обнаружена и исправлена "за бугром" еще в 2000 г. Однако, когда в фидо возник вопрос по этому поводу, никто не привел метода решения этой проблемы. Эта ошибка исправлена в Delphi6, но так как многие еще продолжают использовать Delphi5, то в данном материале предлагается описание ошибки и метод ее исправления.
| Итак... |
В Delphi 5 есть ошибка в процедуре _AddRefArray в модуле System.pas. Если вы попробуете выполнить следующий код, то получите сообщение об ошибке: Invalid variant operation.
| procedure func(p: array of variant); begin if Length(p) > -1 then ShowMessage(p[0]); end; procedure TForm1.Button1Click(Sender: TObject); begin func([]); end |
Дело в том, что компилятор Delphi автоматически вставляет в код процедуры func вызов _AddRefArray, а эта процедура не может корректно работать с пустым массивом.
Исправить ошибку несложно, достаточно добавить проверку на количество элементов массива в процедуру _AddRefArray, которая находится в модуле system.pas. Исправленный текст _AddRefArray приведен ниже:
| procedure _AddRefArray { p: Pointer; typeInfo: Pointer; elemCount: Longint}; asm { -> EAX pointer to data to be referenced } { EDX pointer to type info describing data } { ECX number of elements of that type } PUSH EBX PUSH ESI PUSH EDI TEST ECX,ECX JZ @@exit MOV EBX,EAX MOV ESI,EDX MOV EDI,ECX ... |
Затем надо скомпилировать system.pas с отладочной информацией и без и заменить файлы Delphi5\lib\system.dcu и Delphi5\lib\Debug\system.dcu. Для этого я написал небольшой bat-файл, который надо поместить в каталог Delphi5\Source\Rtl и запустить его на выполнение.
| del lib\system.dcu make copy lib\system.dcu ..\..\lib\system.dcu del lib\system.dcu make -DDEBUG copy lib\system.dcu ..\..\lib\Debug\system.dcu |
Хочу заметить, что для компиляции требуется файл tasm32.exe, который не поставляется с Delphi.
После выполнения этих действий ошибка будет устранена. Однако остается одна нерешенная проблема - в проекте нельзя использовать пакет времени выполнения vcl50.bpl. Если собрать проект с использованием пакетов, то будет использована функция не из исправленного модуля system.dcu а из пакета vcl50.dcu. Ситуация усугубляется тем, что модуль vcl50.bpl нельзя корректировать.
Другой способ исправления _AddRefArray я нашел на , желающие могут обратиться по
Идея оказалась очень простой - раз нельзя исправить процедуру _AddRefArray в файле vcl50.bpl, значит ее нужно исправить в памяти программы во время работы. Ниже я привожу исходный текст, который я оставил практически без изменений:
| unit PatchAddRefArray; interface implementation uses Windows; var NewAddRefArray: Pointer; OldAddRefArray: Pointer; procedure _NewAddRefArray { p: Pointer; typeInfo: Pointer; elemCount: Longint}; asm { -> EAX pointer to data to be referenced } { EDX pointer to type info describing data } { ECX number of elements of that type } { проверка на количество элементов в массиве} TEST ECX, ECX JZ @exit { старый код затертый командой перехода} PUSH EBX PUSH ESI PUSH EDI MOV EBX,EAX MOV ESI,EDX { продолжить выполнение процедуры _AddRefArray} JMP OldAddRefArray @exit: end; type TJumpDWord = packed record OpCode: Word; Distance: Pointer; end; PJumpDWord = ^TJumpDWord; PPointer = ^Pointer; const // Несколько инструкций из AddRefArray: // PUSH EBX, PUSH ESI и т.д. COrigARACode = $89D689C389575653; // JMP CJmpCode = $25FF; procedure PatchAddRef; var Jmp: TJumpDWord; Addr: ^TJumpDWord; OldProtect: DWORD; begin {Получить адрес процедуры AddRefArray} asm mov eax, offset System.@AddRefArray mov Addr, eax end; {Переход к телу процедуры AddRefArray} while Addr^.OpCode = CJmpCode do Addr := PPointer(Addr^.Distance)^; {Сравнить начало процедуры AddRefArray с ее "сигнатурой" если совпадает, значит это та процедура, которую мы ищем} if PInt64(Addr)^ = COrigARACode then begin OldAddRefArray := Pointer(Integer(Addr) + SizeOf(TJumpDWord) + 1); NewAddRefArray := @_NewAddRefArray; Jmp.OpCode := CJmpCode; Jmp.Distance := @NewAddRefArray; VirtualProtect(Addr, SizeOf(TJumpDWord), PAGE_READWRITE, OldProtect); Addr^ := Jmp; VirtualProtect(Addr, SizeOf(TJumpDWord), OldProtect, OldProtect); end; end; initialization PatchAddRef; end. |
В заключение я бы хотел заметить, что везде где это возможно при описании входных параметров следует использовать параметр const. Это позволит сэкономить как вычислительные ресурсы так и память.
Олег Мотов
январь 2003г.
домашняя страница материала нет комментариев.
Отдельное спасибо
(да я знаю, что благодарности помещают в конце, но там их редко кто читает :))так вот отдельное спасибо:
Спасибо человеку, который сделал из меня программиста.
Спасибо Королеве Елене Филипповой. Если вы здесь, то вы знаете за что.:)
Эта программа написана в то время когда меня можно было легко "взять на "слабо"". Так вот спасибо тому кто меня подначил на ее написание :)
Открытие файлов DFM версий 5 и 6 в младших версиях
| Раздел Сокровищница |
Появление новых версий Delphi затруднило жизнь (программистскую) тех, кто остался верен версии 4: она не может открыть проект, созданный ее потомками.
Причина проста - файлы формы сохранили расширение (DFM), но принципиально изменили содержание: в версии 4 они имели двоичный формат, в следующих версиях - стали текстовыми. Однако разработчики отказались от использования стандартного для таких файлов расширения TXT (видимо, чтобы народ не пытался работать с ними в обычных текстовых редакторах - может плохо кончиться), и новое расширение ввести не решились (DFT, например). В результате открытие проекта, созданного под версией 5-6, в версии 4 сопровождается сообщением об ошибке создания формы из-за неверного формата потока - и форма не создается. Соответственно проект невозможно использовать.
Выход, однако, есть, и даже два. Один заложен в самой Delphi: в папке BIN есть утилита convert.exe, которая как раз и занимается переводом файла формы из двоичного формата (с расширением DFM) в текстовый (с расширением TXT) и обратно. Единственная тонкость - нужно вручную сменить расширение файла формы из проекта версий 5-6: вместо DFM должно стать TXT. Дальше утилита легко создаст файл формы в родном формате с нужным расширением.
Второй вариант (если менять расширение не хочется) - воспользоваться специальными утилитами:
Таким образом, притормозившие на версии Delphi-4 вполне могут изучать самые современные проекты. Простая смена формата - вовсе не повод для огорчений или спешной закупки новой версии Delphi. Конечно, в версиях 5 и 6 огромное количество преимуществ и достоинств, но если версия 4 справляется со всеми вашими задачами - не надо тратить деньги.
Отображение длинных строк при движении мыши по списку для нескольких TListBox.
| Раздел Сокровищница | анович Олег, дата публикации 19 марта 2002г. |
При движении по списку TListBox содержимое каждой строки показывается с помощью Hint-а. Код поддерживает обработку нескольких TListBox на форме.
{Вставляем в раздел public вашей формы:} procedure ShowHint (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); {Вставляем где нибудь после implementation:} procedure TForm1.ShowHint (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); var ListRect,a: TRect; begin with HintInfo do begin {Здесь необходимо указать все ListBox на вашей форме, например в этом случае это ListBox1 и ListBox2} if (HintControl = ListBox1)or(HintControl = ListBox2) then with HintControl as TListBox do begin if (ItemAtPos(CursorPos,true)<>-1)and (Canvas.TextWidth(items.Strings[ItemAtPos(CursorPos,true)]) > ItemRect(ItemAtPos(CursorPos,true)).Right-2)then begin HintStr := items.Strings[ItemAtPos(CursorPos,true)]; ListRect := ClientRect; ListRect.Top := ListRect.Top + (ItemAtPos(CursorPos,true)-TopIndex)*ItemHeight; ListRect.Bottom := ListRect.Top + ItemHeight; CursorRect := ListRect; GetWindowRect(Handle,a); HintInfo.HintPos:=Point(ListRect.Left+a.Left+1,ListRect.Top+a.Top-1); end; end; end; end; {В обработчике FormShow формы прописываем:} Application.OnShowHint := ShowHint; Application.HintHidePause:=5000; //Время которое будет держаться Hint. Application.HintPause:=300; //Время перед появлением Hint'а. {В обработчике FormHide формы прописываем:} Application.HintHidePause:=2500; Application.HintPause:=500; Во всех ListBox'ах устанавливаем свойсто ShowHint в True
Агранович Олег
Смотрите по этой теме:
Отправка SMS на мобильные телефоны МТС
| Раздел Сокровищница |
Я долго мучался над этой проблемой, и наконец нашёл оптимальное ДЛЯ СЕБЯ решение:
Парсер комбинированных выражений
| Раздел Сокровищница | рь Серебренников, дата публикации 22 января 2002г. |
Долго искал парсер и компилятор комбинированных выражений, но так и не нашел - только математика. Пришлось сделать самому.
Парсер вычисляет любые выраженя, состоящие из констант, функций и знаков действий (операций) между ними. Костанты четырех типов - целочисленные, вещественные, строки и логические. Операции - какие душе угодно, функции - тоже. Результатом вычислений является запись - упрощенный аналог типа Variant (нужно было для переноса на C++).
Примеры выражений: 2**2+4 "Pi is "+3.14 'The bool expression is ' + iif(2>3 && !('A' < 'B'), "True", "False") "Html YELLOW is ""#" + Hex(0xff 1. Парсер работает с четырьмя типами выражений
Скачать исходные коды: (11K)
Перехват меню IE ( TWebBrowser ) и подмена его собственным PopupMenu
| Раздел Сокровищница | рь Серебренников , дата публикации 29 августа 2001г. |
После ответа на вопрос КС о блокировании контекстного меню IE (), получил кучку писем с просьбой выслать модуль, который это делает.
Думаю, такая информация полезна для народа.
Модуль просто подключается к проекту. После этого все меню (TWebBrowser.PopupMenu) начинают работать нормально.
unit WbPopup; interface // Для преобразования кликов правой кнопкой в клики левой, раскомментировать // {$DEFINE __R_TO_L} implementation uses Windows,Controls,Messages,ShDocVw; var HMouseHook:THandle; function MouseProc( nCode: Integer; // hook code WP: wParam; // message identifier LP: lParam // mouse coordinates ):Integer;stdcall; var MHS:TMOUSEHOOKSTRUCT; WC:TWinControl; {$ifdef __R_TO_L} P:TPoint; {$endif} begin Result:=CallNextHookEx(HMouseHook,nCode,WP,LP); if nCode=HC_ACTION then begin MHS:=PMOUSEHOOKSTRUCT(LP)^; if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then begin WC:=FindVCLWindow(MHS.pt); if (WC is TWebBrowser) then begin Result:=1; {$ifdef __R_TO_L} P:=WC.ScreenToClient(MHS.pt); if WP=WM_RBUTTONDOWN then PostMessage(MHS.hwnd,WM_LBUTTONDOWN,0,P.x + P.y shl 16); if WP=WM_RBUTTONUP then PostMessage(MHS.hwnd,WM_LBUTTONUP,0,P.x + P.y shl 16); {$endif} if (TWebBrowser(WC).PopupMenu<>nil) and (WP=WM_RBUTTONUP) then begin TWebBrowser(WC).PopupMenu.PopupComponent:=WC; TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y); end; end; end; end; end; initialization HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID); finalization CloseHandle(HMouseHook); end.
Переименование группы файлов
| Раздел Сокровищница |
Приложение является доработкой примера из поставки Дельфи "X:\Program Files\Borland\Delphi6\Demos\ActiveX\ShellExt\" Потребность в данной программе возникла при необходимости переименовать группу выделенных файлов, с чем она прекрасно справляется.
Пример позволяете переименовывать группу файлов в проводнике Windows 95/98/ME. Поддерживается шаблонная операция [*] (звездочка). Приложение интегрируется в оболочку проводника и добавляет команду в контекстное меню. Поддерживает английский и русский язык автоматически (как мне кажется :-)).
Примеры шаблонов:
Вы можете доработать алгоритм шаблонной операции, чтобы сделать его более развернутым.
Все основные операции по переименованию в следующих методах (файл ZRFile.pas): procedure TContextMenu.RenameFiles; function TContextMenu.RenameTemplate(strTemplate, strName: String): String;
Скачать проект: (200 K)
Перенаправление вывода консольной программы
| й, дата публикации 02 июня 2003г. |
Понадобилось мне отобразить работу консольной программы в каком-нибудь Memo, а саму консоль не показывать. Поискал в инете - много кто ищет, мало кто предлагает готовые решения. Понял только, что плясать надо с "пайпами". Взял свой парадный бубен и... Вовремя подвернулась хорошая статья в тему на КД: рбань С.В. Но мне не нужен целый класс! Да и собственные наработки уже появились. Вообщем, не буду утомлять процессом поисков и метаний, просто скажу что получилось. А получилась следующая функция:
| function RunAny(CommandLine: string; Str: TStrings): boolean; var I: byte; S: string; Flag: boolean; tRead, cWrite, dwRead, dwAvail: cardinal; SA: TSecurityAttributes; PI: TProcessInformation; SI: TStartupInfo; begin Result:=False; SA.nLength:=SizeOf(SECURITY_ATTRIBUTES); SA.bInheritHandle:=True; SA.lpSecurityDescriptor:=nil; if not CreatePipe(tRead, cWrite, @SA, 0) then Exit; ZeroMemory(@SI, SizeOf(TStartupInfo)); SI.cb:=SizeOf(TStartupInfo); SI.dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW; SI.wShowWindow:=SW_HIDE; SI.hStdOutput:=cWrite; if CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, nil, SI, PI) then begin CloseHandle(PI.hProcess); CloseHandle(PI.hThread); Str.Clear(); Flag:=True; while Flag do begin for I:=0 to 9 do begin PeekNamedPipe(tRead, nil, 0, nil, @dwAvail, nil); if (dwAvail>0) then begin Flag:=True; Break; end else Flag:=False; Sleep(100); end; //for I:= if dwAvail>0 then begin SetLength(S, dwAvail); ReadFile(tRead, PChar(S)^, Length(S), dwRead, Nil); OemToChar(PChar(S), PChar(S)); Str.Add(S); Application.ProcessMessages; Result:=True; end; // if dwAvail end; // while Flag end; // if CreateProcess end; |
Вот. Может кому пригодится. Естественно пока не причесано, но спешу поделиться :-)
P.S. с format. Да, действительно, такая проблема существует. Под win98SE у меня так и не получилось с тем же format''ом и рядом архиваторов, таких как RAR 2.0 и ARJ 2.50. Однако, под WIN200 PROF RUS все решилось небольшим изменением: CommandLine:=''cmd.exe /c ''+CommandLine - и телемаркет!
Работает даже с bat-файлом.
Перевод "короткого" имени файла (short filename) в "длинное" (long filename)
| Раздел Сокровищница |
Столкнулся с необходимостью перевода "короткого" имени файла (short filename) в "длинное" (long filename). Дело в том что существующая функция Win32 API GetLongFilename не поддерживается в Windows 95(r) и в Delphi по этой же причине не инкапсулирована.
Предлагаю свой вариант функии. Функция работает как с сетвыми, так и с локальными именами. Вход: short(string) filename, выход: long filename(string) или пустая строка(string), в случае некоректного имени файла. Текст оной прилагаю ниже. uses Windows, SysUtils{для функции FileExists()}; function GetLongFileName(InputName: string): string; var Root, Net: Boolean; InPath, CurP, BegP: PChar; CurItem, CurPath, OutPath: string; RootGuard: SmallInt; FindHandle: Cardinal; FindData: WIN32_FIND_DATA; begin if not FileExists(InputName) then begin Result:= ''; Exit; end;{if not FileExists(InputName) then} OutPath:= InputName; InPath:= PChar(InputName); Root:= True; Net:= False; RootGuard:= 0; CurP:= InPath; while CurP^<>#0 do begin BegP:= CurP; while (CurP^<>'\') and (CurP^<>#0) do CurP := CharNext(CurP); SetString(CurItem, BegP, CurP - BegP); if CurItem='' then CurPath:= CurPath+'\' else begin CurPath:= CurPath+CurItem; if Root then begin OutPath:= CurPath; CurPath:= CurPath+'\'; end;{if Root then} end;{if CurItem='' then CurPath:= CurPath+'\' else} if (CurPath='\\') or (CurPath='\') then Net:= True; if Root then begin if Net then begin RootGuard:= -1; Net:= False; end;{if Net then} Inc(RootGuard); if RootGuard>0 then Root:= False; end{if Root then} else begin FindHandle:= FindFirstFile(PChar(CurPath), FindData); OutPath:= OutPath+'\'+FindData.cFileName; Windows.FindClose(FindHandle); CurPath:= CurPath+'\'; end;{if Root then ... else} CurP := CharNext(CurP); end;{while CurP^ <> #0 do} Result:= OutPath; end;{GetLongFileName}
По мотивам обсуждения :
Не столько в качестве "ответов", сколько в качестве самостоятельного дополнения и пояснения к статье. >>Еще куча всяких "бонусов", просто лень описывать>Никаких других бонусов не наблюдаю. Ну, что же, перечислю...
Первоначальный вариант Игоря Василенко
| with TMyDlg.Create(nil) do try if execute then ... begin end; finally free; end; |
Мой вариант
| ShowMessage('Вы ввели '+InputString('Начальное значение')); |
Другие Бонусы:
> К тому же проверка правильности введенного значения будет производится,
> как я понял на основе исходников, после выхода из формы диалога.
> Я предпочитаю делать это до, чтобы дать пользователю возможность исправить
> ошибку без повторного открытия диалога. Итак. Оговорка №1 - это концепт!!! Я специально сидел и удалял незначащий код! Проверки, защиту от ошибок и т.д.!
Кроме того, а это что???
| If ShowModal = mrOk Then Result:=Edit1.Text Else Result:='"Отмена"'; |
Итак...
Во первых, основная цель написания такого рода диалогов - СТАНДАРТИЗАЦИЯ процедур и интерфейсов ввода.
Вторая задача - РАЗГРУЗИТЬ код ОСНОВНЫХ модулей программы. Т.е. Чем короче вызов диалога - тем лучше. Крайне желательно, чтобы основной модуль получал ТОЛЬКО результат ввода (успех/НЕуспех) и, в случае успешного ввода - данные. Все. Все проверки, защита и т.д. ДОЛЖНЫ быть ВЫНЕСЕНЫ из рабочих модулей программы. Если ввод с ограничением диапазонов и т.д. - пишите диалог, принимающий на вход список ограничений и реализующий их! Не тащите это в основной модуль! > Возвращает единственное строковое значение, а зачастую их должно быть > несколько.
> Что делать? Запихивать все в строку, а после проводить разбор на мой взгляд
> неприемлемо. Ок. Приведу пример ввода МНОГИХ переменных. Да еще и по именам, да еще и в разных комбинациях и количествах...
| function InputStringsByName(BeginVal: TStrings): TModalResult; Var i: Integer; Cmpnt: TComponent; begin With TOptionsDlg.Create(Application.MainForm) do Try //Иницализируем поля начальными значениями For i:= 0 to BeginVal.Count - 1 do begin Cmpnt:=FindComponent(BeginVal.Names[i]); If Cmpnt is TEdit Then (Cmpnt as TEdit).Text:=BeginVal.ValueFromIndex[i] Else Try If Cmpnt is TSpinEdit Then (Cmpnt as TSpinEdit).Value:=StrToInt(BeginVal.ValueFromIndex[i]) Except End; end; //Показываем диалог Result:=ShowModal; //Если ввод успешен - копируем введенные значения на место начальных If Result = mrOk Then For i:= 0 to BeginVal.Count - 1 do begin Cmpnt:=FindComponent(BeginVal.Names[i]); If Cmpnt is TEdit Then BeginVal.ValueFromIndex[i]:=(Cmpnt as TEdit).Text Else Try If Cmpnt is TSpinEdit Then BeginVal.ValueFromIndex[i]:=IntToStr((Cmpnt asTSpinEdit).Value); Except End; end; Finally Free; End; end; |
добавлено 19.12.02
Скачать:
Главное отличие - формат файлов форм... Остальное должно работать "на ура"
Получение адреса из входящего сообщения в MS Outlook
| Раздел Сокровищница | ров Алекс, дата публикации 30 апреля 2002г. |
Функция демонстрирует решение проблемы, связанной с получением адреса из входящего сообщения в MS Outlook Function GetEAddr(InputMailItem : Variant {mailitem}) : String; Var MapiFile: TextFile; FirstLine, MailAddress : String; StrLength, Index : Integer; begin MailAddress := ''; // Сохраняем сообщение в текстовом файле... InputMailItem.SaveAs(WideString(ExtractFilePath(Application.EXEName) + 'mailitem.txt'), $00000000); // Если рассмотреть структуру созданного файла, то в первой строке кроме всего прочего, // содержится электронный адрес отправителя. Задача состоит в том, чтобы прочитать его... AssignFile(MapiFile, ExtractFilePath(Application.EXEName) + 'mailitem.txt'); Reset(MapiFile); Readln(MapiFile, FirstLine); CloseFile(MapiFile); If Pos('@', Trim(FirstLine)) > 0 Then Begin StrLength := Length(Trim(FirstLine)); Index := StrLength; While FirstLine[Index] <> ' ' Do Dec(Index); MailAddress := Copy(FirstLine, Index + 1, StrLength - Index); For Index := 1 To Length(Trim(MailAddress)) Do If (MailAddress[Index] = '[') Or (MailAddress[Index] = ']') Then MailAddress[Index] := ' '; MailAddress := Trim(MailAddress); End Else MailAddress := Trim(InputMailItem.SenderName); Result := MailAddress; // В том случае, если адрес все же не определен, возвращаем известный нам SenderName... end;
Поверхностный подход
| Раздел Сокровищница |
При работе с полями в формате "дата-время" объектов типа TDataSet мои коллеги неоднократно сталкивались с проблемой поведения маски. Недавно у меня тоже возникла задача работы с такими полями. Возможно, ни один из нас просто не разобрался, как нужно делать правильно, но нужно было действовать.
Проблема заключается в том, что при вводе с клавиатуры требуется обязательно указывать все знаки, включая ненужные в конкретном случае (временную часть). В противном случае генерируется ошибка:
'Invalid input value. Use escape key to abandon changes'
После часа, потраченного на разбирательство с маской, возникло желание написать собственный компонент. Спросив у коллег, которые уже ходили этим путем, я решил посмотреть в исходниках - вдруг получится быстро обойти этот вопрос.
Не буду брать на себя смелость комментировать, что и как делается в модуле Mask.pas. Кто хочет, может разобраться самостоятельно - ничего особо сложного там нет.
Для начала в свойстве EditMask замените символ BlankChar с '_' на '0'. В результате получится маска вроде
!99/99/99 99:99:99;1;0
Чтобы при редактировании и просмотре значение выглядело одинаково, укажите свойство DisplayFormat
dd.mm.yy hh:nn:ss
Далее нужно добавить в проект файлы Consts.pas, Sysconsts.pas и Mask.pas. После внесения изменений закройте Дельфи, и открыв снова, перекомпилируйте проект. Затем указанные файлы можно исключить из проекта. Пример приведен для Дельфи 5.
Изменения следующие:
Consts.pas //SMaskEditErr = 'Invalid input value. Use escape key to abandon changes'; SMaskEditErr = 'Введено некорректное значение. Нажмите Esc для отмены'; SysConsts.pas
//SInvalidDateTime = '''%s'' is not a valid date and time'; SInvalidDateTime = '''%s'' - некорректное значение даты и времени'; Mask.pas
function TCustomMaskEdit.RemoveEditFormat(const Value: string): string; … {шестая строка снизу} {так было} // if Result[I] = FMaskBlank then // Result[I] := ' '; {так стало} if Result[I] = FMaskBlank then if FMaskBlank='0' then Result[I] := FMaskBlank else Result[I] := ' '; … function TCustomMaskEdit.Validate(const Value: string; var Pos: Integer): Boolean; … {одинадцатая строка снизу} {так было} // if (Value [Offset] = FMaskBlank) or // ((Value [Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii)) then if (FMaskBlank<>'0') and ((Value [Offset] = FMaskBlank) or ((Value [Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii))) then … В завершении хочу поделиться полезной и простой функцией. Как правило, при создании документа, мы вставляем текущие дату и время. При этом секунды как правило не нужны. function GetDateTimeWOSec(DateTime: TDateTime): TDateTime; begin Result:=StrToDateTime(FormatDateTime('dd.mm.yy hh:nn',DateTime)); end;
После проведения описанных манипуляций с полем в формате дата-время становиться так же приятно работать, как с компонентом TRXDateEdit.
Житель без титула Виктор Светлов
Практический пример
Также я сделал небольшой пример того, как можно использовать этот модуль на практике. Программа Drawing рисует картику по уже готовым математическим формулам, находящимся в файле Drawing.dat. Вы можете его открыть при помощи блокнота. Вы также можете вписать туда свои формулы. При создании этой программы мне пришлось зарегистрировать несколько новых функций. Первая из них (x) используется для расчета координаты X, вторая (y) используется для получения координыты Y, функция index возвращает индекс текущего пикселя. Напоминаю, что начало координат находится в верхнем левом углу. Кстати, если формула написана неправильно, то она будет проигнорирована, а для расчета картинки требуется как минимум три правильных формулы, по одной для кажного цвета: красного, зеленого и синего. Программа каждый раз при расчете картики выбирает случайные формулы. При стандартном разрешении 1024 : 768 получаем, что для вычисления одного составляющего всех пикселей картинки требуется произвести 1024 * 768 = 786432 операций, а всего 786432 * 3 = 2359296 операций. На моем компьютере расчет всей картинки занимает 1 - 3 секунды. На старых компьютерах расчет будет занимать намного больше времени, например, я был неприятно удивлен, когда запустил эту же программу на компьютере Celeron-400, там картинка расчитывалась 5 - 10 секунд.Правильные диалоги от Борланда
| рбань С.В., дата публикации 16 декабря 2002г. |
Почитал тут статью . Гммм.. Все в целом верно, но неудобно. Не хочу обижать РАЗДО более удачную конструкцию (которую, кстати, я уже давно использую).
Еще раз подчеркну - это не моя придумка, а ребят из Борланда.
Эта конструкция позволяет:
В этом примере я привел два наиболее типичных случая. 1-й - InputString - просто ввод, без анализа отмены, второй - MrInputString - с анализом отмены ввода (ModalResult).
Оба случая используют начальные значения. Без них - Еще проще...
В принципе - ваша фантазия ничем не ограничивается. Я, например, храню последние вводившиеся значения в реестре и читаю их оттуда после создания формы. Удобно.
Пользователь не мается вводя по 10 раз одно и то же, а у меня не болит голова с инициализацией полей (есть специальный класс, который этим занимается, но это отдельная тема...)
ИСХОДНИКИ:
| //************************************************************** //Основной модуль Обратите Внимание! "uses Dialog;" implementation {$R *.dfm} uses Dialog; procedure TForm1.BitBtn1Click(Sender: TObject); begin ShowMessage('Вы ввели '+InputString('Начальное значение')); end; procedure TForm1.BitBtn2Click(Sender: TObject); Var Str: String; begin Str:='Начальное значение'; If MrInputString(Str) = mrOk Then ShowMessage('Вы ввели '+Str) Else ShowMessage('Вы отменили ввод'); end; //******************************************************** //Модуль диалога unit Dialog; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Buttons; type TOptionsDlg = class(TForm) Bevel1: TBevel; BitBtn1: TBitBtn; BitBtn2: TBitBtn; Edit1: TEdit; Label1: TLabel; Bevel2: TBevel; Label3: TLabel; procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private { Private declarations } public { Public declarations } end; var OptionsDlg: TOptionsDlg; function InputString(BeginVal: String): String; function MrInputString(Var Str: String): TModalResult; implementation {$R *.dfm} function InputString(BeginVal: String): String; begin With TOptionsDlg.Create(Application.MainForm) do Try Edit1.Text:=BeginVal; If ShowModal = mrOk Then Result:=Edit1.Text Else Result:='"Отмена"'; Finally Free; End; end; function MrInputString(Var Str: String): TModalResult; begin With TOptionsDlg.Create(Application.MainForm) do Try Edit1.Text:=Str; Result:=ShowModal; Str:=Edit1.Text; Finally Free; End; end; procedure TOptionsDlg.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin Case Key of 27: ModalResult:=mrCancel; 13: ModalResult:=mrOk; End; end; end. |
| Невизуальный компонент для преобразования денежной суммы в пропись. За образец был взят метод, используемый в 1С. Т.е. вся сумма хранится в текстовом файле. Подгружая этот файл, можно управлять выводом суммы. Таким образом в примере реализована многоязыковая "сумма прописью". В MInWord.zip находятся: |   |
NetShareAdd , NetShareDel для Win9x
| Раздел Сокровищница | ан Николаевич, дата публикации 14 мая 2002г. |
Предлагается еще один пример реализации функций создания(удаления) расшаренного диска для Win9x
Procedure NetShareDriveC(SetShared: Boolean); const LM20_NNLEN = 12; SHPWLEN = 8; SHI50F_RDONLY = 1; SHI50F_FULL = 2; SHI50F_DEPENDSON = (SHI50F_RDONLY or SHI50F_FULL); SHI50F_ACCESSMASK = (SHI50F_RDONLY or SHI50F_FULL); SHI50F_PERSIST = 256; SHI50F_SYSTEM = 512; STYPE_DISKTREE = 0; ACCESS_NONE = 0; ACCESS_READ = $01; ACCESS_WRITE = $02; ACCESS_CREATE = $04; ACCESS_EXEC = $08; ACCESS_DELETE = $10; ACCESS_ATRIB = $20; ACCESS_PERM = $40; ACCESS_GROUP = $8000; ACCESS_ALL = (ACCESS_READ or ACCESS_WRITE or ACCESS_CREATE or ACCESS_EXEC or ACCESS_DELETE or ACCESS_ATRIB or ACCESS_PERM); type share_info_2= record shi2_netname : PWideChar; shi2_type : DWORD; shi2_remark : PWideChar; shi2_permissions : DWORD; shi2_max_uses : DWORD; shi2_current_uses : DWORD; shi2_path : PWideChar; shi2_passwd : PWideChar; end; share_info_50 = packed record shi50_netname : array [0..LM20_NNLEN] of Char; shi50_type : Byte; shi50_flags : Short; shi50_remark : PChar; shi50_path : PChar; shi50_rw_password: array [0..SHPWLEN] of Char; shi50_ro_password: array [0..SHPWLEN] of Char; end; var hDll : THandle; NetShareAddWin9x : function(pszServer : PChar; sLevel : Short; pbBuffer : Pointer; cbBuffer : Short):DWORD;stdcall; NetShareDelWin9x : Function(pszServer : PChar; pszNetName : PChar; usReserved : Short):DWORD;stdcall; si50 : share_info_50; si2 : share_info_2; tamano : Short; res, err : DWORD; EsNT: Boolean; Begin If SetShared then begin hDll := LoadLibrary('SvrApi.dll'); if hDll > 32 then begin // NetShareAdd NetShareAddWin9x := GetProcAddress(hDll, 'NetShareAdd'); tamano := sizeof(si50); FillChar(si50, tamano, 0); StrCopy(si50.shi50_netname, 'SH_ACCESS'); si50.shi50_type := STYPE_DISKTREE; si50.shi50_flags := SHI50F_Full; //SHI50F_RDONLY; si50.shi50_path := 'C:\'; StrCopy( si50.shi50_rw_password, 'siemensw'); StrCopy( si50.shi50_ro_password, 'siemens'); res := NetShareAddWin9x(nil, 50, @si50, tamano); Showmessage('NetShare added to C:\Test .'); FreeLibrary(hDll); end; end else begin hDll := LoadLibrary('SvrApi.dll'); if hDll > 32 then begin // NetShareDel NetShareDelWin9x := GetProcAddress(hDll, 'NetShareDel'); res := NetShareDelWin9x(nil, PChar('SH_ACCESS'), 0); Showmessage('NetShare deleted. Check C:\test .'); FreeLibrary(hDll); end; end; End;
Смотрите по теме:
Пример работы по последовательному порту
| Раздел Сокровищница | атьев, дата публикации 22 марта 2001г. |
Модуль для работы с весами (ПетВес серия EB4) по последовательному порту
Реально работающий "драйвер" и может быть использован по назначению.
Скачать модуль (2K) ... type ComPort = 1..4; const ComPortName : array [ComPort] of string = ('COM1','COM2','COM3','COM4'); type TWeightAdapter = class ( TComponent ) private FPort : ComPort; FTimeOut : integer; function GetWeight: double; procedure SetPort(const Value: ComPort); public constructor Create( AOwner : TComponent );override; function AsString: string; published property Weight : double read GetWeight; property Port : ComPort read FPort write SetPort; property TimeOut : Integer read FTimeOut write FTimeOut; end; function GetWeight ( Port : integer = 1 ): double; procedure Register; implementation uses SysUtils,Windows; function GetWeight ( Port : integer = 1 ): double; var A : TWeightAdapter; Begin A := TWeightAdapter.Create(nil); A.Port := Port; Result := A.Weight; A.Free; End; const SIncorrectPort = 'Неверный номер порта'; SPortNotOpen = 'Невозможно открыть порт'; { TWeightAdapter } function TWeightAdapter.AsString: string; begin result := Format('%f',[weight]); end; constructor TWeightAdapter.Create(AOwner: TComponent); begin inherited Create( AOwner ); FTimeOut := 2; FPort := 1; end; function TWeightAdapter.GetWeight: double; var S : string; hComm,Readed : Cardinal; Buffer : byte; Mode : TDCB; TimeOuts : COMMTIMEOUTS; StartTime,Finish : TDateTime; Done : boolean; const Numbers = ['0'..'9','.',',']; Function GetString : string ; var B,E : integer; Begin B := 0; E := Length(S); While (E>0) and (S[E]<>#13) do Dec(E); If E>0 then B := E; While (B>0) and (S[B]<>#10) do Dec(B); If B>0 then Result := Copy(S,B+1,E-1) else Result := ''; End; function ParseString : extended; var T,S : string; // 'ST, 102,12kgG'#13#10 begin result := -1; S := GetString; // Формат : ST. 100.05 kgG // ST/US/OL : Стабильно / нестабильно / перегруз // Число : вес // KG : Единица измерения ( других похоже нет ) // H/G/L : Верхний предел/норма/нижний предел T := UpperCase(Copy(S,1,2)); If (T='US') or (T='OL') then Exit; If (T='ST') or (T='+ ') or (T='- ') then Begin While ((Length(S)>0) and (not (S[1] in ['0'..'9']))) do Delete(S,1,1); T := ''; While (Length(S)>0) and (S[1] in Numbers) do Begin If (S[1] = ',') then T := T+'.' else T := T+S[1]; Delete(S,1,1); End; Val(T,Result,Readed); Done := true; End; end; begin Result := 0; if csDesigning in ComponentState then Exit; Finish := FTimeOut / 86400; Done := false; // Открываем HComm := CreateFile( PChar(ComPortName[Port]), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0); if hComm = INVALID_HANDLE_VALUE then raise Exception.Create(SPortNotOpen); with Mode do Begin BaudRate := 9600; ByteSize := 8; Parity := NOPARITY; StopBits := ONESTOPBIT; Flags := EV_RXCHAR + EV_EVENT2; End; SetCommState ( hComm, Mode ); // Устанавливаем таймауты with TimeOuts do Begin ReadIntervalTimeout := MAXDWORD; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 0; End; SetCommTimeOuts(hComm,TimeOuts); // Собираем строку StartTime := Now; repeat ReadFile(hComm,Buffer,1,Readed,nil); If Readed>0 then Begin S := S+Char(Buffer); Result := ParseString; End; until (Now-StartTime>Finish ) or Done; // Заметаем следы CloseHandle(HComm); // Закрываем хэндл файла end; procedure TWeightAdapter.SetPort(const Value: ComPort); begin If (Value>0) and (Value<5) then FPort := ComPort(Value) else raise Exception.Create(SIncorrectPort); end; ...
дата публикации 10 ноября 2001г.
| Раздел Сокровищница | тов, дата публикации 10 ноября 2001г. |
В этом архиве представлены 3 версии программы, которая демонстрирует работу со слоями(Layers) в Windows 2000: Берется форма, на нее накладывается рисунок (любой). Форма окна подгоняется под рисунок (цвет точки в координатах [0,0] считаем прозрачным).
Потом - две новые прикольные WinAPI функции.
Прозрачными формами тоже кто-то развлекался.
В каталоге D5 - версия для Delphi5 с объявлением внешних функций API Windows 2000. Написана Ярославом Богатовым (aka AnorAglar)
Аскетизм и прямолинейность кода демонстрируют не только соответствующие качества мозга программиста, но и позволяют запихать всё в один модуль, где всё понятно и без комментариев.
В каталоге NewLayer - версия для Delphi5. Оптимизирована Андреем Пляко (aka EinWill)
P.S.
Код Андрея Пляко опубликован с согласия чной теме смотрите проекты Антона Григорьева:
Пример работы с окнами средствами Win API
| Раздел Сокровищница | анович Олег, дата публикации 21 марта 2002г. |
| Приложенные файлы: Смотрите материалы Королевства по этой теме: |  |
Принцип работы
Компонент ищет таблицу по ячейкам ее верхнего ряда (шапка таблицы). Существует структура типа TTableInfo, которая описывает критерии поиска:TFilterOption = (foCaseInsensitive, foSoftFiltration);
THeadLine = record Cells: array of string; FilterOptions: array of TFilterOption; end;
TBorderOption = (boRight, boBottom);
TBorderOptions = set of TBorderOption;
TTableInfo = record HeadLine: THeadLine; Rect: TRect; BorderOptions: TBorderOptions; TableIndex, BottomIndex: Integer; end; Описание шапки таблицы находится в элементе TTableInfo.HeadLine, где TTableInfo.HeadLine.Cells это строковый массив верхнего ряда ячеек, а TTableInfo.HeadLine.FilterOptions это массив, который соответствует каждой ячейки массива TTableInfo.HeadLine.Cells и определяет способ сравнения элементов массива TTableInfo.HeadLine.Cells с ячейками таблицы Excel. TTableInfo.HeadLine.FilterOptions может быть двух типов:
Элемент TTableInfo.Rect обозначает координаты и размеры таблицы по отношению к шапке таблицы:
Задавать ширину (Rect.Right) и высоту (Rect.Bottom) таблицы не обязательно, так как компонент сам может определять размеры таблицы. Для автоопределения ширины таблицы, элемент TTableInfo.BorderOptions должен содержать boRight и, соответственно, для автоопределения высоты таблицы TTableInfo.BorderOptions должен содержать boBottom. Определение границы осуществляется путем нахождение первой пустой ячейки. Просмотр таблицы в документе Excel происходит сверху вниз, слева направо. Для изменения способа обнаружения нижней границы таблицы используется еще один элемент: TTableInfo.BottomIndex. Он определяет колонку, которая должна содержать пустую ячейку. Например, если TTableInfo.BorderOptions включает в себя boBottom и TTableInfo.BottomIndex равен 0, то определение высоты таблицы будет находиться по первой пустой ячейке колонки 0, на рисунке это колонка "A":
В таком случае высота таблицы будет равна 7, то есть будет содержать в себе 7 рядов. Если же TTableInfo.BorderOptions включает boBottom и TTableInfo.BottomIndex равен 1, то определение высоты таблицы будет находиться по первой пустой ячейке колонки 1, на рисунке это колонка "B" и высота таблицы будет равна 5, то есть будет содержать в себе 5 рядов.
Так как в документе Excel может быть найдена более чем одна таблица, удовлетворяющая условиям структуры TTableInfo, то существует элемент: TTableInfo.TableIndex. Он указывающий на индекс нужной таблицы. Чаще всего документ Excel содержит в себе только одну искомую таблицу, поэтому целесообразно задавать значение TTableInfo.TableIndex равным 0.
Для импорта таблицы используется функция:
function ImportTable(Table: TTable; TableInfo: TTableInfo): Boolean; virtual;
В ней указывается таблица Table, которая будет заполнена соответствующими данными и информация о таблице, которую необходимо найти. Если все прошло успешно, то функция возвращает истину. Прежде чем импортировать таблицу, нужно открыть документ Excel. Это делается с помощью процедуры:
procedure Open(const FileName: string); virtual;
Параметр FileName содержит путь к файлу Excel. Соответственно, после открытия файла его нужно закрыть. Делается это с помощью процедуры:
procedure Close(SaveChanges: Boolean); virtual;
Параметр SaveChanges определяет, нужно ли сохранять изменения.
Процесс экспотра таблицы намного проще процесса импорта. Для задания условий экспортирования используется структура:
TExportTableInfo = record Cell1, Cell2: string; Rect: TRect; end; Элементы TExportTableInfo.Cell1 и TExportTableInfo.Cell2 задают координаты левой верхней ячейки экспортируемой таблицы в формате Excel. То есть, например, если необходимо экспортировать таблицу в самое начало документа Excel, то задаем значение TExportTableInfo.Cell1 равным "A", значение TExportTableInfo.Cell2 равным "1", в таком случае левая верхняя ячейка таблицы разместиться в документе Excel по адресу "A1". Элемент TExportTableInfo.Rect определяет смещение экспортируемой таблицы относительно координат TExportTableInfo.Cell1 и TExportTableInfo.Cell2. Используются только элементы Left и Top структуры TExportTableInfo.Rect. На первый взгляд это кажется бессмысленным. Действительно, зачем нужно смещение, если и так можно задать любую координату элементами TExportTableInfo.Cell1 и TExportTableInfo.Cell2? Все дело в том, что в Excel специфическая система координат. Для пользователя она весьма удобна, а для программиста это небольшая проблема. Горизонтальная координата - это система исчисления, состоящая из английского алфавита. То есть, двадцатишестиричная система исчисления. Но беда в том, что в этой системе исчисления нет нуля. То есть если использовать двадцатишестиричную систему исчисления по правилам, то A это 0, B это 1, C это 2 и так далее. Но в любом документе присутствуют такие координаты, как AA, AB, AC и так далее. По всем правилам они должны выглядеть, как A, B, C и так далее, так как первым числом ноль (A) никогда не ставится. Но это все философия. Вернусь к тому, от чего я ушел. Если нужно задать координату, скажем 100:200, то не нужно пересчитывать горизонтальную координату в формат Excel, достаточно установить, скажем, TExportTableInfo.Cell1 в "A", TExportTableInfo.Cell2 в "1", TExportTableInfo.Rect.Left в 100 и TExportTableInfo.Rect.Top в 200.
Проблемы копирования русского текста в clipboard и обратно
| рь Цысь ( Igoreha ), дата публикации 24 апреля 2003г. |
У многих возникает проблема с копированием русского текста в буфер обмена на ОС Win2000 и WinXP а может и Win9x. Простого и надежного решения данной проблемы найти, к сожалению, не удалось :-( Представляю модуль который поможет решить проблему копирования русского текста в clipboard и обратно.
Спасибо всем, кто помог решить эту проблему !!!
Нужно просто добавить в проект ...
| unit RusClipboard; interface uses Clipbrd; type TRusClipboard = class(TClipboard) private procedure SetCodePage(const CodePage: longint); public procedure Open; override; procedure Close; override; end; implementation uses Windows; { TRusClipboard } procedure TRusClipboard.Close; begin SetCodePage($0419); inherited; end; procedure TRusClipboard.Open; begin inherited; SetCodePage($0419); end; procedure TRusClipboard.SetCodePage(const CodePage: longint); var Data: THandle; DataPtr: Pointer; begin // Назначить кодовую страницу для буфера обмена Data:= GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, 4); try DataPtr := GlobalLock(Data); try Move(CodePage, DataPtr^, 4); SetClipboardData(CF_LOCALE, Data); finally GlobalUnlock(Data); end; except GlobalFree(Data); end; end; var FClipboard: TClipboard; OldClipboard: TClipboard; initialization // Установить клипборд FClipboard:= TRusClipboard.Create; OldClipboard:= SetClipboard(FClipboard); if OldClipboard <> nil then OldClipboard.Free; end. |
Процедура печати TStringList на принтер
Процедура печатает TStringList на принтер, переносит на следующий лист бумаги, если список не помещается.Поля - фиксированные в пол-дюйма.
procedure PrintStrings(S: TStrings; Font: TFont; Title: string); var LeftMargin, TopMargin, LineCoord, LineOnPage, LinesOnDoc, CurrentLine, TextHeight, LinesPerPage, LineInterval: integer; procedure StartDoc; begin LinesOnDoc := S.Count; Printer.Canvas.Font.Assign(Font); Printer.Canvas.TextOut(0, 0, ' '); LeftMargin := (Printer.Canvas.Font.PixelsPerInch) div 2; TopMargin := (Printer.Canvas.Font.PixelsPerInch) div 2; TextHeight := Abs(Printer.Canvas.Font.Height); LineInterval := TextHeight + (TextHeight div 2); LinesPerPage := (Printer.PageHeight - TopMargin) div LineInterval; CurrentLine := 0; end; function MorePages:boolean; begin Result := (CurrentLine < LinesOnDoc) and not Printer.Aborted; end; procedure StartPage; begin LineOnPage := 0; LineCoord := TopMargin; end; procedure NextPage; begin if MorePages then Printer.NewPage; end; function MoreLines:boolean; begin Result := (LineOnPage < LinesPerPage) and (LineOnPage < LinesOnDoc) and not Printer.Aborted; end; procedure NextLine; begin Inc(LineOnPage); Inc(LineCoord, LineInterval); Inc(CurrentLine); end; procedure PrintLine; begin Printer.Canvas.TextOut(LeftMargin, LineCoord, S.Strings[CurrentLine]); end; begin Printer.Title := Title; Printer.BeginDoc; StartDoc; while MorePages do begin StartPage; while MoreLines do begin PrintLine; NextLine; Application.ProcessMessages; end; NextPage; end; Printer.EndDoc; end;
Алексей Еремеев
Смотрите так же:
Процедура выравнивает "уехавшую" форму внутри рабочей части экрана
procedure SafeFormPlace(Form: TForm); var R: TRect; L,T: integer; begin if not SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0) then with Screen do R := Bounds(0, 0, Width, Height); L := Form.Left; if L < R.Left then L := R.Left else if (L + Form.Width) > R.Right then L := R.Right - Form.Width; T := Form.Top; if T < R.Top then T := R.Top else if (T + Form.Height) > R.Bottom then T := R.Bottom - Form.Height; Form.SetBounds(L, T, Form.Width, Form.Height); end;Алексей Еремеев
Проект "Warp Button". Иллюстрация к статье "Пространство имен оболочки Windows"
| Раздел Сокровищница | н , дата публикации 23 августа 2001г. |
Этот фриварный проект может принести как практическую, так и теоретическую пользу. Фактически это иллюстрация к статье известного гуру Акжана Абдулина (есть в Свитках и на его личном сайте). Именно она послужила толчком и основанием для этой разработки.
Идея проста. Хотелось получить в Windows функциональность кнопки Warp оболочки WarpCenter операционной системы OS/2 Warp 4.0 Merlin. Отличается она от кнопки Start Explorer'а тем, что показывает не отдельно формируемое меню, а иерархическое содержимое десктопа. То есть, все, что есть на десктопе и во вложенных папках, она разворачивает в виде меню и позволяет запускать.
Скачать проект: exe-файл + исходные коды (52 K)
Программа ставится в автостарт и помещает свой значок в System Tray.
Исходные тексты могут ответить на массу часто задаваемых вопросов о программировании в Windows. Вот некоторые темы:
В основу положен принцип "Лучше день потерять, потом за пять минут долететь" (с) мультик. При старте зачитываются все объекты, зато потом меню работает быстро. Некоторые известные спецпапки десктопа по-умолчанию не развертываются во вложенное меню (можно отключить в конфигурации). Диски в "My Computer" тоже не развертываются - было бы слишком много объектов. Изменения на самом десктопе контролируются и запускается процедура перечитывания объектов (во вложенных папках контроля нет).
Горячая клавиша вызова меню - Ctrl-Alt-F12. Вызов контекстного меню для выбранного объекта - Ctrl-Enter или правая кнопка мыши.
Проект компилируется в D5, первоначально был написан в среде D3 (есть различия в инициализации COM). Программа была разработана в 1999 году в порядке изучения Delphi и методов работы с API и объектами эсплорера.
Отдельное спасибо Акжану Абдулину за вышеупомянутую статью о пространстве имен, а также Анатолию Тенцеру за его "конструктор юного любителя иконок в SysTray" (модуль TaskBar.pas - его, без изменений).
Программа для тестирования скорости расчета
Программа предназначена для расчета скорости вычисления формул (как математических, так и логических) на Вашем компьютере. В ниспадающем списке я уже приготовил несколько формул различной сложности. Как Вы увидите, скорость вычисления простых и сложных формул различается. Программа также показывает структуру сценария. Структура отображается числами по 4 байта, разделенных между собой знаком пробела. Количество выполняемых операций также можно регулировать.Программа для установки параметров экрана из командной строки
| Агранович, дата публикации 09 января 2003г. |
Утилита, которая меняет параметры экрана на заданные в командной строке.
Может пригодиться дизайнерам, разработчикам софта, а так же тем, кто работает на компьютере не один, и предпочитает пользоваться своими настройками экрана. Достаточно запустить ярлык программы и параметры экрана мгновенно изменятся на указанные в командной строке.
Например команда "ScreenSet.exe 800 600 8 100" установит: разрешение в 800 на 600, глубину цвета в 8 бит на пиксель, а частоту экрана в 100Гц. Запуск программы: "ScreenSet.exe Ширина Высота Цвет Частота" Пример: "ScreenSet.exe 800 600 8 100"
Для изменения параметров экрана используется следующая функция:
| function SetFullscreenMode(PelsWidth, PelsHeight, BitsPerPixel, DisplayFrequency: Integer):Boolean; var DeviceMode : TDevMode; begin with DeviceMode do begin dmSize:=SizeOf(DeviceMode); dmBitsPerPel:=BitsPerPixel; dmPelsWidth:=PelsWidth; dmPelsHeight:=PelsHeight; dmDisplayFrequency:=DisplayFrequency; dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT or DM_DISPLAYFREQUENCY; Result:=ChangeDisplaySettings(DeviceMode,CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL; end; end; |
Скачать исходный код: (12.8 K)
| Для данного материала нет комментариев. |
Программная настройка DCOM
Для программной настройки DCOM можно воспользоваться процедурами модуля BDcomPrmDefaultProperties
| Элемент | Процедура | Описание | 9x | NT |
| Enable Distributed COM on this computer | IsDCOMOk | Проверяет наличие поддержки DCOM | + | + |
| IsEnabledDCOM | Проверяет разрешен ли DCOM на данной машине | + | + | |
| SetEnableDCOM | Разрешает DCOM на данной машине | + | + | |
| IsDCOMProtocolsEnabled | Проверяет наличие протоколов DCOM | - | + | |
| Default Authentication LevelDefault Impersonation Level | IsInitializeSecurityOk | Проверяет можно ли устанавливать параметры Security. Возвращает True для платформы NT и False для 9x | - | + | InitializeDefaultSecurity | Устанавливает параметры Security по умолчанию.Вызов данной процедуры необходимо поместить перед Application.Initialize в клиентской и серверной программе.Процедуру можно вызывать только один раз для текущего процесса.Процедура должна быть вызвана до первого обращения к COM-объекта, требующего маршалинга | .+ | + |
| SetDefaultDCOMCommunicationProperties | Устанавливает параметры по умолчанию для Authentication Level, Impersonation Level | + | + | |
| CreateRemoteComObjectEx | Определяет Authentication Level, Impersonation Level запускаемого серверного приложения.Данная процедура может использоваться вместо CreateRemoteComObject | + | + | |
| Provide additional security for reference tracking | RemoveLegacySecure-References | При разрешении DCOM необходимо вызвать эту процедуру, чтобы сбросить флажок Повышенной безопасности для отслеживания ссылок | + | + |
DefaultSecurity
| Элемент | Процедура | Описание | 9x | NT |
| Enable remote connection | IsDCOMOk, IsEnabledDCOM, SetEnabledDCOM | + | + | |
| Default access permissions | ListDefaultAccessACL | Возвращает в строке описание разрешений доступа к DCOM приложениям по умолчанию. Данное описание может быть выведено в Memo. | - | + |
| ChangeDefaultAccessACL | ChangeDefaultAccessACL Изменяет параметры доступ к DCOM приложениям по умолчанию.Principal - имя пользователя (например Everyone)SetPrincipal - True добавить пользователя в список, False - удалить.Permit - разрешить параметры для указанного пользователя | - | + | |
| Default launch permissions | ListDefaultLaunchACL | Возвращает в строке описание разрешений запуска DCOM приложений по умолчанию. Данное описание может быть выведено в Memo | - | + |
| ChangeDefaultLaunchACL | ChangeDefaultLaunchACL Изменяет параметры запуска DCOM приложений по умолчанию - + | - | + | |
| IsDefaultLaunchAccess-Allowed | Возвращает True, если разрешен запуск DCOM приложений по умолчанию. | - | + |
Application Security
Все процедуры и функции данной категории получают в качестве входного параметра AppID - CLSID объекта сервера.
| Элемент | Процедура | Описание | 9x | NT |
| Access permissions | ListAppIDAccessACL | Возвращает в строке описание разрешений доступа к DCOM приложению. Данное описание может быть выведено в Memo.AppID - CLSID объекта сервера. | - | + |
| ChangeAppIDAccessACL | Изменяет параметры доступ к DCOM приложениям по умолчанию.AppID - CLSID объекта сервера.Principal - имя пользователя (например Everyone)SetPrincipal - True добавить пользователя в список, False - удалить.Permit - разрешить параметры для указанного пользователя | - | + | |
| Default launch permissions | ListAppIDLaunchACL | Возвращает в строке описание разрешений запуска DCOM приложения. Данное описание может быть выведено в Memo.AppID - CLSID объекта сервера. | - | + |
| ChangeAppIDLaunchACL | Изменяет параметры запуска DCOM приложений по умолчанию.AppID - CLSID объекта сервера. | - | + | |
| IsLaunchAccessAllowed | Возвращает True, если разрешен запуск DCOM приложения. | - | + | |
| AllowLaunchAccess | Разрешает запуск DCOM приложения | - | + |
Все процедуры и функции данной категории получают в качестве входного параметра AppID - CLSID объекта сервера.
| Элемент | Процедура | Описание | 9x | NT |
| Which user account do you want to use to run this application | IsInteractiveUser | Проверяет, используется ли для запуска приложения учетная запись взаимодействующего пользователя | - | + |
| SetInteractiveUser | Устанавливает параметр: использовать для запуска приложения учетную запись взаимодействующего пользователя | - | + |
Все остальные процедуры и функции модуля BDcomPrm носят служебный характер.
Абдулин Марат
,
руководитель отдела программирования
Скачать исходные коды: (28 K)
Статьи по теме:
Работа с БД: Поиск и фильтрация.
| Раздел Сокровищница | Автор Александр Мефодьев дата публикации 31 января 2000г. |
П О И С К
1. Метод Locate: function Locate(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean; Метод Locate ищет первую запись, удовлетворяющую критерию поиска, и если такая запись найдена, делает ее текущей. В этом случае в качестве результата возвращается True. Если запись не найдена - False.
Список KeyFields указывает поле, или несколько полей, по которым ведется поиск. В случае нескольких поисковых полей их названия разделяются точкой с запятой. Критерии поиска задаются в вариантном массиве KeyValues так, что i-е значение KeyValues ставится в соответствие i-му полю в KeyFields.
Options позволяет указать необязательные значения режимов поиска: type TLocateOption = (loCaseInsensitive, loPartialKey); TLocateOptions = set of TLocateOption;
В случае, если поля входят в какой-либо индекс, Locate использует этот индекс при поиске. Если искомые поля входят в несколько индексов, трудно сказать, какой из них будет использован. Соответственно трудно предсказать, какая запись из множества записей, удовлетворяющих критерию поиска, будет сделана текущей - особенно в случае, если поиск ведется не по текущему индексу.
При поиске по полям, не входящим ни в один индекс, применяется фильтр BDE. Вот пример использования Locate: procedure TForm1.LocateButtonClick(Sender: TObject); begin Table1.Locate('Field1;Field2', VarArrayOf(['Ма','Зд']), [loPartialKey]); end; В этом примере поиск произведен при помощи одной строчки кода:
2. Метод Lookup
function Lookup( const KeyFields: String; const KeyValues: Variant; const ResultFields: String): Variant; Метод Lookup находит находи нужную запись, но не делает ее текущей, а возвращает значения некоторых полей этой записи. Тип результата - Variant или вариантный массив. Независимо от успеха поиска записи, указатель текущей записи в таблице не меняется. В отличие от Locate, Lookup осуществляет поиск только на точное соответствие критерия поиска и значения полей записи. В KeyFields указывается список полей, по которым необходимо осуществлять поиск. При наличии в этом списке более чем одного поля соседние поля разделяются точкой с запятой. KeyValues указывает поисковые значения полей, список которых содержится в KeyFields.
Если имеется несколько поисковых полей, каждому i-му полю в KeyFields ставится в соответствие i-ое значение в KeyValues. При наличии одного поля его поисковое значение можно указывать в качестве KeyValues непосредственно; в случае нескольких полей их необходимо приводить к типу вариантного массива при помощи VarArrayOf.
В качестве поисковых полей можно указывать поля как входящие в какой-либо индекс, так и не входящие в него; тип текущего индекса не имеет значения. Если поисковые поля входят в какие-либо индексы, их использование производится автоматически; в противном случае используются фильтры BDE.
Если в результате поиска запись не найдена, метод Lookup возвращает Null, что можно проверить с помощью оператора: If VarType(LookupResults) = varNull then ... В противном случае Lookup возвращает из этой записи значения полей, список которых содержит ResultFields. При этом размерность результата зависит от того, сколько результирующих полей указано в ResultFields:
Ф И Л Ь Т Р А Ц И Я
Свойство Filter
Свойство Filter компонента TTable позволяет задать критерий фильтрации. В этом случае база будет отфильтрована, как только свойство Filtered будет равно TRUE. Синтаксис описания критерия похож на синтаксис секции WHERE SQL-запроса с тем исключением, что имена переменных программы указывать нельзя, можно указывать имена полей и литералы (явно заданные значения); можно использовать обычные операции отношения и логические операторы AND, NOT и OR, например:
Эта запись фильтра оставит в таблице записи, в которых поля Doljnost='доцент' и TabNum больше 3000 Filter:='([Doljnost]=''доцент'') and ([TabNum] > 3000)'; Filtered:=True; Строку критерия фильтрации можно ввести во время прогона программы или на этапе конструирования. Например, с помощью такого обработчика события OnChecked компонента CheckBox1 критерий фильтрации считывается из поля Edit1 и помещается в свойство Filter компонента Table1: procedure TForm1.CheckBox1Click(Sender: TObject); begin Table1.Filter := Edit1.Text; Table1.Filtered := CheckBox1.Checked; end; С помощью свойства type TFilterOption = (foCaseInsensitive, foNoPartialCompare); property FilterOptions: TFilterOptions; можно определить дополнительные свойства фильтрации строковых полей:
Событие OnFilterRecord
Событие OnFilterRecord возникает при установке значения True в свойство Filtered. Обработчик события имеет два параметра: имя фильтруемого набора данных и переменную Accept, в которую программа должна поместить True, если текущая запись удовлетворяет условию фильтрации.
В отличие от критерия в строке Filtered, ограниченного рамками синтаксиса условного выражения, критерий, реализуемый в обработчике события OnFilterRecord, определяется синтаксисом Object Pascal и может организовать сложные алгоритмы фильтрации. Однако следует помнить, что в обработчике OnFilterrecord последовательно перебираются все записи БД, в то время как методы SetRange, ApplyRange и им сопутствующие методы компонента TTable используют индексно-последовательный метод, т.е. работают с частью записей в физической БД. Это делает использование обработчика OnFilterRecord предпочтительным для фильтрации небольших объемов записей и сильно ограничивает его применение при больших объемах данных.
Всякий раз, когда приложение обрабатывает событие OnFilterRecord, набор данных переводится из состояния dsBrowse в состояние dsFilter. Это предотвращает модификацию набора данных во время фильтрации. После завершения текущего вызова обработчика события ObFilterRecord набор данных переводится в состояние dsBrowse.
Пример: чтобы создать набор данных из тех записей базы данных, в которых поле "Должность" содержит значение "преподаватель", можно использовать такой обработчик: procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolean); begin Accept := DataSet['Должность'] = 'преподаватель'; end; Еще один пример: отфильтровать базу "Сотрудники" по условию "Отобрать всех, у кого табличный номер (поле "#") больше значения, вводимого пользователем в Edit1, и в поле "ФИО" есть подстрока символов, вводимых пользователем в Edit2":
procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolean); begin Accept := (DataSet['#'] > Edit1.Text) and (Pos(Edit2.Text, DataSet['ФИО']) > 0); end; Если в строке Filter и обработчике события OnFilterRecord заданы разные критерии фильтрации, выполняются оба.
Методы расширенной фильтрации
1. Методы фильтрации
Помимо описываемых ниже методов, присущих только TTable, наборы данных имеют также общие свойства, методы и события для фильтрации - Filter, Filtered, OnFilteredRecord, FindFirst, FindLast, FindNext, FindPrior.
Для фильтрации записей TTable имеет следующие методы:
Фильтрация методами ApplyRange, SetRange должно проводиться по ключевым полям.По умолчанию берется текущий индекс, определяемый свойством TTable.IndexName или TTable.IndexFieldNames. Если значения этих свойств не установлены, по умолчанию используется главный индекс. Поэтому, если нужно использовать индекс, отличный от главного, необходимо явно переустановить значение свойства TTable.IndexName (имя текущего индекса) или TTable.IndexFieldNames (список полей текущего индекса).
2. Использование SetRange
Метод procedure SetRange( const StartValues, EditValues: array of const); показывает не только записи, индексные поля которых лежат в диапазоне [StartValues..EndValues].
Пример: Пусть в наборе данных Table1 показываются все записи. Включим в структуру записи набора данных два поля: "Номер группы" и "Наименование товара". Пусть текущий индекс построен по полю "Номер группы".
Напишем такой обработчик события: CheckBox1.Click: procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp: Integer; begin If CheckBox1.Checked then begin GrNumTmp := StrToInt(Edit1.Text); With Table1 do begin CancelRange; SetRange([GrMunTmp],[GrNumTmp]); end; end else Table1.CancelRange; end; В отфильтрованном наборе данных показываются только те записи, индексное поле текущего индекса у которых (в нашем случае "Номер группы") имеет значение, лежащее в заданном диапазоне. В данном случае диапазон определяется переменной GrNumTmp. Поэтому для GrNumTmp = 3 будут показаны записи, принадлежащие к группе 3.
Если бы мы захотели, чтобы в наборе данных фильтровались записи из нескольких групп, то нам следовало бы добавить в форму второй компонент Edit2, в котором вводился бы номер конечной группы, в то время как в Edit1 вводился бы номер начальной группы: procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp1, GrNumTmp2: Integer; begin If CheckBox.Checked then begin GrNumTmp1 := StrToInt(Edit1.Text); GrNumTmp2 := StrToInt(Edit2.Text); With Table1 do begin CancelRange; SetRange([GrNumTmp1],[GrNumTmp2]); end; end else Table1.CancelRange; end;
Александр Мефодьев,
ICQ 56666220
31 января 2000г. Специально для
Работа с локальной сетью - NetShareAdd
| Раздел Сокровищница |
Долго и упорно мучался по освоению этой функции и, наконец, решил эту проблему (не без помощи добрых людей :).
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); end; Share_INFO_2= record shi2_netname:PWideChar; // ОБЯЗАТЕЛЬНО PWideChar иначе работать не будет... shi2_type:DWORD; shi2_remark:LPTSTR; shi2_permissions:DWORD; shi2_max_uses:DWORD; shi2_current_uses:DWORD; shi2_path:PWideChar; shi2_passwd:LPTSTR; end; PShare_INFO_2 = ^Share_INFO_2; LPShare_INFO_2 = ^Share_INFO_2; SHARE_INFO_502 =record shi502_netname: PCHAR; shi502_type: DWORD; shi502_remark: PCHAR; shi502_permissions: DWORD; shi502_max_uses: DWORD; shi502_current_uses: DWORD; shi502_path: PCHAR; shi502_passwd: PCHAR; shi502_reserved: DWORD; shi502_security_descriptor: PSECURITY_DESCRIPTOR; end; PSHARE_INFO_502= ^SHARE_INFO_502; LPSHARE_INFO_502=^SHARE_INFO_502; const STYPE_DISKTREE = $0001; ACCESS_READ = $0001; var Form1: TForm1; F:Cardinal; function NetShareAdd( Server : PwideChar; level : cardinal; Buf : Pointer; var Parm_Err : DWORD):Cardinal;stdcall; external 'netapi32.dll' name 'NetShareAdd'; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var buf:Pointer; UserInf:Share_INFO_2; UserInf502:Share_INFO_502; err:dWord; begin err:=0; f:=0; UserInf.shi2_netname:='test'; UserInf.shi2_type:=0; UserInf.shi2_remark:='test'; UserInf.shi2_permissions:=1; UserInf.shi2_max_uses:= 1; UserInf.shi2_current_uses:=0; UserInf.shi2_path:='C:\test'; UserInf.shi2_passwd:=nil; GetMem(Buf ,sizeof(UserInf)); F:=NetSHAREAdd(nil,2,@UserInf,err); FreeMem(Buf); end; end.
Расширение возможностей стандартной функции MessageDlg
| рякин Руслан, дата публикации 04 июля 2003г. |
Функция TimedMessageBox представляет собой расширение возможностей стандартной функции MessageDlg (большая часть кода взята из нее же). Дополнительной является возможность закрытия окна сообщения по таймеру без участия пользователя (в случае его отсутствия за компьютером).
Может пригодиться при длительных обработках, когда нужно и вывести какое-либо сообщение пользователю, и продолжить работу, даже если он его проигнорировал (например в файловых менеджерах при копировании большого количества файлов: если какой-то из них не читается, весь процесс останавливается, хотя логичнее было бы просто пропустить этот файл и записать информацию об ошибке в лог, если пользователь не ответил на сообщение).
Скачать: (230K)
В архиве содержится сам модуль, демонстрационная программа (dpr и exe) и картинки, используемые в кнопках.
| Для данного материала нет комментариев. |
Реализация шаблонов в Delphi
| Раздел Сокровищница | ркуша Алексей, дата публикации 07 сентября 2001г. |
Многие скажут что сабж невозможен. Но...посмотрите что у меня получилось (На примере простого списка).
Итак.
Необходимо создать два пустых ((Через File-> New->Text или в файловой системе) без interface, implementation, uses... и т.д.) .pas файла.
Первый назовем InterfaceTemp.pas(заголовок), второй ImplementTemp.pas(реализация). Далее копируем, соответственно, в них в InterfaceTemp.pas (заголовочный файл шаблона): TemplateList = class // заголовочный файл шаблона (для ordinal types или real types, shortstring) private FList: PIntList; FCount: Integer; FCapacity: Integer; protected procedure Grow; function Get(Index: Integer): _DATA_TYPE_; // Вот оно чудо :-) procedure Put(Index: Integer; Item: _DATA_TYPE_); procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); public destructor Destroy; override; class procedure Error(const Msg: string; Data: Integer); overload; virtual; class procedure Error(Msg: PResStringRec; Data: Integer); overload; function Add(Item: _DATA_TYPE_): Integer; procedure Clear; function Last: _DATA_TYPE_; function First: _DATA_TYPE_; procedure Delete(Index: Integer); procedure Exchange(Index1, Index2: Integer); function IndexOf(Item: _DATA_TYPE_): Integer; procedure Insert(Index: Integer; Item: _DATA_TYPE_); procedure Move(CurIndex, NewIndex: Integer); procedure Sort; function Min: _DATA_TYPE_; function Max: _DATA_TYPE_; property Count: Integer read FCount write SetCount; property Items[Index: Integer]: _DATA_TYPE_ read Get write Put; default; end; в ImplementTemp.pas (файл реализации шаблона): function TemplateList.Add(Item: _DATA_TYPE_): Integer; begin Result := FCount; if Result = FCapacity then Grow; FList^[Result] := Item; Inc(FCount); end; procedure TemplateList.Clear; begin SetCount(0); SetCapacity(0); end; procedure TemplateList.Delete(Index: Integer); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Dec(FCount); if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(_DATA_TYPE_)); end; destructor TemplateList.Destroy; begin Clear; end; procedure TemplateList.Exchange(Index1, Index2: Integer); var Item: _DATA_TYPE_; begin if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1); if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2); Item := FList^[Index1]; FList^[Index1] := FList^[Index2]; FList^[Index2] := Item; end; function TemplateList.Get(Index: Integer): _DATA_TYPE_; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Result := FList^[Index]; end; procedure TemplateList.Grow; var Delta: Integer; begin if FCapacity > 64 then Delta := {371053//}FCapacity div 4 else if FCapacity > 8 then Delta := 16 else Delta := 4; SetCapacity(FCapacity + Delta); end; function TemplateList.IndexOf(Item: _DATA_TYPE_): Integer; begin Result := 0; while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result); if Result = FCount then Result := -1; end; procedure TemplateList.Insert(Index: Integer; Item: _DATA_TYPE_); begin if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index); if FCount = FCapacity then Grow; if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(_DATA_TYPE_)); FList^[Index] := Item; Inc(FCount); end; function TemplateList.Max: _DATA_TYPE_; var i: Integer; begin if Fcount=0 then Error(@SListCountError, 0); Result:=Flist^[0]; for i:=0 to Fcount-1 do if Result < Flist^[i] then Result:=Flist^[i]; end; function TemplateList.Min: _DATA_TYPE_; var i: Integer; begin if Fcount=0 then Error(@SListCountError, 0); Result:=Flist^[0]; for i:=0 to Fcount-1 do if Result>Flist^[i] then Result:=Flist^[i]; end; procedure TemplateList.Move(CurIndex, NewIndex: Integer); var Item: _DATA_TYPE_; begin if CurIndex <> NewIndex then begin if (NewIndex < 0) or (NewIndex >= FCount) then Error(@SListIndexError, NewIndex); Item := Get(CurIndex); Delete(CurIndex); Insert(NewIndex, Item); end; end; procedure TemplateList.Put(Index: Integer; Item: _DATA_TYPE_); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); FList^[Index] := Item; end; procedure TemplateList.SetCapacity(NewCapacity: Integer); begin if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error(@SListCapacityError, NewCapacity); if NewCapacity <> FCapacity then begin ReallocMem(FList, NewCapacity * SizeOf(_DATA_TYPE_)); FCapacity := NewCapacity; end; end; procedure TemplateList.SetCount(NewCount: Integer); begin if (NewCount < 0) or (NewCount > MaxListSize) then Error(@SListCountError, NewCount); if NewCount > FCapacity then SetCapacity(NewCount); if NewCount > FCount then FillMemory(@(FList^[FCount]), (NewCount - FCount) * SizeOf(_DATA_TYPE_),0); FCount := NewCount; end; procedure QuickIntSort(ia: PIntList; iLo,iHi : integer); var Lo, Hi : Integer; // индексы Mid, T : _DATA_TYPE_; // значения begin Lo := iLo; Hi := iHi; Mid := ia[(Lo+hi) shr 1]; repeat while ia[Lo] < Mid do Inc(Lo); while ia[Hi] > Mid do Dec(Hi); if Lo Hi; if Hi > iLo then QuickIntSort(ia,iLo,Hi); if Lo < iHi then QuickIntSort(ia,Lo,iHi); end; procedure TemplateList.Sort; begin if (FList <> nil) and (FCount > 0) then QuickIntSort(FList, 0, FCount - 1); end; class procedure TemplateList.Error(const Msg: string; Data: Integer); function ReturnAddr: Pointer; asm MOV EAX,[EBP+4] end; begin raise Exception.CreateFmt(Msg, [Data]) at ReturnAddr; end; class procedure TemplateList.Error(Msg: PResStringRec; Data: Integer); begin TemplateList.Error(LoadResString(Msg), Data); end; function TemplateList.Last: _DATA_TYPE_; begin Result := Get(FCount - 1); end; function TemplateList.First: _DATA_TYPE_; begin Result := Get(0); end; Теперь необходимо создать файл для так называемого "typedef" (Файл указания конкретного типа). На примере типа Currency (ImplCurrencyList.pas), для другого типа создайте еще один файл с другим названием, например (ImplIntegerList.pas)
Итак Currency:
unit ImplCurrencyList; interface uses windows, sysutils; {$H-} // длинные строки недопустимы type _DATA_TYPE_ = Currency; // здесь указывается настоящий тип {$H+} const MaxListSize = Maxint div (4*sizeof(_DATA_TYPE_)); type PIntList = ^TIntList; TIntList = array[0..MaxListSize - 1] of _DATA_TYPE_; {$I InterfaceTemp} // соответственно тип уже обозначен и реален type TCurrencyList = TemplateList; // здесь задается тип реального класса списка implementation uses Consts; {$I ImplementTemp} // соответственно тип уже обозначен и реален end.
Вот собственно и все. Теперь подключате модуль нужного типа uses ImplCurrencyList или ImplIntegerList.
И
var cyr: TCurrencyList или
var intlist: TIntegerList; где то. (если вы создали два или более "typedef" файла для других типов byte, Extended).
Данный пример работает с обычными типами данных (не объектными). Для объектов можно завернуть "перегрузку операторов"
Например: TBase = class // это пример для дальнейших обсуждений function doPlus(value: TBase): TBase; overload; // для выполнения оператора+ (если конечно договорится, что doPlus подразумеывает оператор +) function doPlus(value: integer): TBase; overload; function doPlus(value: real): TBase; overload; end; Соответсвенно где то в шаблоне (очень примитивный пример) function TemplateClass.Add(Item: _DATA_TYPE_): Integer; // например TemplateClass и _DATA_TYPE_ есть TBase; begin self.doPlus(Item); {для TBase} Result:=self.a; // какое-то внутреннее поле (пример) end; Вот такие дела в Delphi творятся. Любая критика и предложения принимаются.
Скачать пример (6.2K)
Регистрация приложения в SimpleService в Win9x
| Раздел Сокровищница |
Функция регистрирует свое приложение (откуда вызвана) в SimpleService в Win9x (не будет видно в TaskManager и может работать до того, как пользователь вошел в систему, запуская из ключа реестра
HKLM\Software\Microsoft\Windows\CurrentVersion\RunServices
или HKLM\...\RunServicesOnce и продолжает работать после окончания сессии пользователя)
Булевый параметр - включение или выключение режима
Возвращаемое значение - True в случае успеха
Особенность - функция не критична к операционной системе, программа запустится даже под WinNT (где такая функция не существует в принципе), а результат работы будет False.
function RegisterServiceProcessEx(Enable: boolean): boolean; type TRSP = function (H: THandle; K: dword): dword; stdcall; var RSP: TRSP; begin @RSP := GetProcAddress(GetModuleHandle(PChar('kernel32.dll')), PChar('RegisterServiceProcess')); Result := Assigned(@RSP); if Result then begin if Enable then Result := (RSP(0, 1) = 1) else Result := (RSP(0, 0) = 1); end; end;
Алексей Еремеев
Системное меню по произвольному событию в произвольном месте
| Раздел Сокровищница |
Может кому пригодится....
Событие OnFilterRecord
Событие OnFilterRecord возникает при установке значения True в свойство Filtered. Обработчик события имеет два параметра: имя фильтруемого набора данных и переменную Accept, в которую программа должна поместить True, если текущая запись удовлетворяет условию фильтрации.В отличие от критерия в строке Filtered, ограниченного рамками синтаксиса условного выражения, критерий, реализуемый в обработчике события OnFilterRecord, определяется синтаксисом Object Pascal и может организовать сложные алгоритмы фильтрации. Однако следует помнить, что в обработчие OnFilterrecord последовательно перебираются все записи БД, в то время как методы SetRange, ApplyRange и им сопутствующие методы компонента TTable используют индексно-последовательный метод, т.е. работаютс частью записей в физической БД. Это делает использование обработчика OnFilterRecord предпочтительным для фильтрации небольших объемов записей и сильно ограничивает его приминение при больших объемах данных.
Всякий раз, когда приложение обрабатывает событие OnFilterRecord, набор данных переводится из состояния dsBrowse в состояние dsFilter. Это предотвращает модификацию набора данных во время фильтрации. После завершения текущего вызова обработчика события ObFilterRecord набор данных переводится в состояние dsBrowse.
Пример: чтобы создать набор данных из тех записей базы данных, в которых поле "Должность" содержит значение "преподаватель", можно использовать такой обработчик:
| procedure TForm1. Table1FilterRecord(DataSet: TDataSet; var Accept: Boolena); begin Accept := DataSet['Должность'] = 'преподаватель'; end; |
Еще один пример: отфильтровать базу "Сотрудники" по условию "Отобрать всех, у кого табличный номер (поле "#") больше значения, вводимого пользователем в Edit1, и в поле "ФИО" есть подстрока символов, вводимых пользователм в Edit2":
| procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolena); begin Accept := (DataSet['#'] > Edit1.Text) and (Pos(Edit2.Text, DataSet['ФИО']) > 0); end; |
Если в строке Filter и обработчике события OnFilterRecord заданы разные критерии фильтрации, выполняются оба.
Сокровищница:
Секреты ListBox.| Раздел Сокровищница | Автор статьи Кейт Вуд, Delphi Developer 11/99, Перевод с английского: Владимир Татарчевский. дата публикации 01.12.99 |
Предисловие не от автора
Предлагаемый материал показывает два способа, которыми можно представить данные в компоненте ListBox в виде нескольких колонок. Задача эта не представляется сложной и поэтому мне хотелось бы кое-что пояснить перед прочтением этой страницы.
Статья с названием "Секреты ListBox" была опубликована в ноябрьском номере журнала "Delphi Developer". Помещая ее перевод в Сокровищницу мы преследовали две цели: во-первых ответить на вопрос о нескольких колонках и, во-вторых, желая повеселить наших жителей романтичным повествованием на тему "Хотелось ли вам когда-либо отображать табулированный список...?".
Автор статьи представлен как независимый технический писатель и программист-аналитик. Оставим на его совести выражения типа "Другая малоизвестная особенность ListBox заключается в том, что он может отображать несколько колонок...", возможно эта особенность и малоизвестна, если не заглядывать в Help, не говоря уже о наличии свойства Columns прямо в ObjectInspector'е.
Но несмотря ни на что, ответ на вопрос "как отображать в ListBox несколько колонок" эта статья дает исчерпывающий.
Приятного чтения! Секреты ListBox
ListBox - скромный компонент, появившийся еще в Delphi 1.0. Он показывает список строк и позволяет вам выбрать одну или несколько из них. Однако, как показывает в этой статье Кейт Вуд (Keith Wood), этот компонент имеет редко используемые возможности, которые могут сделать интерфейс вашего приложения более информативным.
Хотелось ли вам когда-либо отображать табулированный список - несколько колонок текста? Как же нам сделать ровные колонки? Вы можете попробовать использовать пробелы, но такой метод не будет работать с пропорциональными шрифтами. Вы можете сделать owner-draw и сформировать колонки самостоятельно. Но вся эта работа не нужна! ListBox уже имеет свойство, которое позволит разершить данную ситуацию.
Свойство TabWidth устанавливает табуляционные интервалы в ListBox. Они измеряются в единицах диалогового окна (dialog box unit), четыре единицы равны сердней ширине символа. Когда это свойство установлено в 0 (по умолчанию), интервалы табуляции в ListBox отсутствуют и символы табуляции отображаются в виде вертикальных линий. Установленное в ненулевое значение, это свойство определяет расстояние между табуляционными метками, расставленными по всей ширине ListBox.
Колонки различной ширины
Что если вы захотите сделать колонки переменной ширины?
Разумеется, нет свойства, позволяющего вам легко сделать это, но это легко делается с помощью кода. Все, что вам нужно сделать - это послать сообщение LB_SETTABSTOPS, передав количество табуляций и указатель на массив с их позициями:
const iStops : array [1..3] of Integer = ( 20, 60, 80 ); begin SendMessage( ListBox1.Handle, LB_SETTABSTOPS, High( iStops ), LongInt( @iStops )); end;
Функция High возвращает индекс последнего элемента в массиве. Если массив индексирован с единицы, вы можете увеличивать количество табуляций, просто добавляя к массиву новые элементы.
Вы также должны установить свойство TabWidth в ненулевое значение, только в этом случае ListBox будет готов принять это сообщение.
Для вставки символа табуляции в ваш текст просто используйте ASCII-символ 9, к примеру так:
ListBox1.Items.Add( Format( '%d'#9'%s'#9'%0:d'#9'%s', [i, Chr( i + Ord( 'A' ) - 1 )] ) ); Несколько колонок
Другая малоизвестная особенность ListBox заключается в том, что он может отображать несколько колонок, стоит вам установить их количество в свойстве Columns.
Теперь строки в ListBox будут расположены по типу газетных столбцов, с горизонтальной полосой прокрутки, появляющейся при необходимости. Строки, не помещающиеся в отведенное для них место обрезаются.
Обе эти возможности просто изменяют вид ListBox. Все остальные функции компонента при этом работают как обычно.
 |
| Рисунок 1 |
Заключение
Итак, наш скромный ListBox имеет скрытые таланты. Мы увидели, как сделать табулированный список с помощью свойства TabWidth и сообщения LB_SETTABSTOPS. Мы также увидели, как создать мультиколонный список с помощью свойства Columns. Запомните это до следующего раза, когда вы будете использовать ListBox.
Кейт Вуд - австралиец, находящийся в данное время в США. Он программист-аналитик в фирме CCSC, базирующейся в Атланте и независимый технический писатель. Его опыт работы с продуктами Borland ведет свое начало с Turbo Pascal для CP/M.
Создание базы данных Interbase во время выполнения программы.
| Раздел Сокровищница | ров Алексей, дата публикации 01 августа 2002г. |
# - разделитель инструкций Sql; Можете ставить, какой нравится... CREATE TABLE MAILTREE( CODE INTEGER NOT NULL PRIMARY KEY, APARENT VARCHAR(255), ACURRENT VARCHAR(255));# CREATE TABLE MAILBASE( CODE INTEGER NOT NULL PRIMARY KEY, FOLDER VARCHAR(255), ISUNREAD SMALLINT DEFAULT 0, AUTHOR VARCHAR(255), SENDERNAME VARCHAR(1000), SENDERSTYLE VARCHAR(1000), RECIPIENT VARCHAR(1000), SUBJECT VARCHAR(255), MSGSIZE DECIMAL(10, 5), MSGRECIEVED VARCHAR(50), ATTACHMENTS SMALLINT, FILELIST VARCHAR(1000), MSGBODY BLOB);# CREATE GENERATOR MTCODE;# SET GENERATOR MTCODE TO 0;# CREATE GENERATOR MBCODE;# SET GENERATOR MBCODE TO 0;# CREATE TRIGGER ADD_MAILTREE FOR MAILTREE ACTIVE BEFORE INSERT AS BEGIN NEW.CODE = GEN_ID(MTCODE, 1); END;# CREATE TRIGGER ADD_MAILBASE FOR MAILBASE ACTIVE BEFORE INSERT AS BEGIN NEW.CODE = GEN_ID(MBCODE, 1); END;# CREATE TRIGGER UPDATE_MAILTREE FOR MAILTREE ACTIVE BEFORE UPDATE AS BEGIN IF (OLD.ACURRENT <> NEW.ACURRENT) THEN UPDATE MAILBASE SET FOLDER = NEW.ACURRENT WHERE FOLDER = OLD.ACURRENT; END;#
Создание системы голосовых сообщений из подручных средств
Смотря, очередной фантастический боевик, в котором “умная” система управления приятным женским или мужским голосом сообщает герою, что если он не выполнит какие-то важные действия то дальше ему (ей) придется передвигаться без удобств на своих двоих или вообще дожидаться завершения фильма в виде горстки атомов.
Вы не раз задумывались, вот бы сделать себе подобную сообщалку о всяческих опасных ситуациях возникающих в вереной Вам компьютерной системе или сети.
Наметим себе цели, которые мы хотим достичь:
События, которые можно проверять ограничиваются исключительно Вашей фантазией. Можно организовать каждые 5 минут с 9:00 до 18:00 c перерывом на обед посылку сигнала PING на конечные компьютеры сети и если не получен ответ поднимать тревогу. Каждые пол часа проверять количество свободного места на HDD. Наличие одновременно включенного (и при этом работающего) комплекта аппаратных средств (сервера, мосты, печатающие устройства). Или организовать на компьютере шефа проверку базы данных с информацией о заработной плате, если она не увеличилась в течении месяца на оговоренное заранее число “президентов” сообщать шефу, мнение о нем как о руководителе и о фирме в целом.
На простых пользователей производит неизгладимое впечатление, когда компьютер сообщает им о том, что они посмели запустить ПО на которое у них нет позволения.
Практически у каждого уважающего себя производителя компьютерного железа в стандартной конфигурации присутствует звуковая карта, которая наиболее часто используются исключительно для воспроизведения audio CD и МР3 файлов. Дополнительно из техники нужно будет приобрести микрофон.
Для облегчения себе задачи в вопросы синтезирования речи вникать не будем, а необходимые нам сообщения попросту запишем в файлы WAV при помощи стандартной программы Windows Звукозапись (понятно, что для этого нужно микрофон воткнуть в соответствующее гнездо звуковой карты).
Как видно без необходимости контролировать время наступления события не обойтись поэтому для сокращения затрат сил и времени все задачи отслеживания времени для наступления проверки условий возложим на почему-то незаслуженно игнорируемую стандартную программу Windows планировщик заданий. Это такая маленькая пиктограмма справа внизу экрана .
Естественно никто не запрещает Вам написать эту часть кода программы, самим, увеличивая размер исполнительного модуля, но думаю программисты фирмы MICROSOFT сделали это лучше .
Для воспроизведения WAV файлов используем описанную почти во всех солидных учебниках по программированию на DELPHI функцию WIN API BOOL sndPlaySound(LPCSTR lpszSound, UINT fuSound);, полное описание которой находится в файле WIN32S.HLP
Откроем новый проект (да будет прощено мне WINDOWхульство) для уменьшения размера уничтожим в файле проекта код, отвечающий за создание окна
Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run;
Удаление этого кода даст нам дополнительный эффект: активное окно не будет терять фокус при воспроизведении звукового сообщения. В качестве примера проверим наличие файлов в указанной папке при помощи простого кода
| rez:=FindFirst(‘c:/*.*’, faAnyFile-16, SearchRec); FindClose(SearchRec); IF rez=0 then {--Возпроизведение звука---} sndplaysound(pchar(‘mysound.wav’),SND_SYNC); |
Существует альтернативный путь, описать сообщения которым можно присвоить звуки в реестре WINDOWS вызывая их потом из программы. Но для этого нужно иметь познания в структуре реестра и WIN API.
Простой пример программы анализа наличия файлов в папке.
| program sexsot; uses Forms,Windows,SysUtils,MMsystem,inifiles,classes, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} var REZ,i:integer; erasefolder:Tstringlist; inifilefolder:tinifile; strpath,strmax,strcount,strsound:string; SearchRec: TSearchRec; begin if FileExists(paramstr(1)) then begin erasefolder:=Tstringlist.create; inifilefolder:=Tinifile.create(extractfilepath(paramstr(0))+paramstr(1)); inifilefolder.readsections(erasefolder); for i:=0 to erasefolder.count-1 do begin strpath:=inifilefolder.readstring(erasefolder[i],'Pathlook','C:\*.*'); strmax:=inifilefolder.readstring(erasefolder[i],'maxcount','1'); strcount:=inifilefolder.readstring(erasefolder[i],'count','0'); strsound:=inifilefolder.readstring(erasefolder[i],'filesound','1.wav'); {---- Проверка наличия файлов------} rez:=0; rez:=FindFirst(strpath, faAnyFile-16, SearchRec); FindClose(SearchRec); {---------------------------------------------} if rez=0 then begin inifilefolder.writestring(erasefolder[i],'count',inttostr(strtoint(strcount)+1)); end else begin inifilefolder.writestring(erasefolder[i],'count','0'); end; strcount:=inifilefolder.readstring(erasefolder[i],'count','0'); if strtoint(strcount)>=strtoint(strmax) then {--Возпроизведение звука---} sndplaysound(pchar(strsound),SND_SYNC); end; end; end. |
| [modem] PathLOOK=f:\mail\out\*.* filesound=nosend.wav maxcount=3 count=0 [email] PathLOOK=с:\unlx\out\*.* filesound=atasunlx.wav maxcount=2 count=0 |
март 2003г.
| Для данного материала нет комментариев. |
Sqlw
| | источник информации: |
| Техническая документация - список зарезервированных слов Local SQL BDE | |
| | |
| Список зарезервированных слов «Local SQL in the Borland Database Engine» в алфавитном порядке. ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING, AT, AUTO, AUTOINC, AVG BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY, BYTES CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT, CURSOR DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT, DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS, EXIT, EXTERNAL, EXTRACT FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP, GROUP_COMMIT_WAIT_TIME HAVING, HOUR IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT, INTEGER, INTO, IS, ISOLATION JOIN KEY LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE, LOG_BUFFER_SIZE MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME, MONEY, MONTH NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS, NUMERIC OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION, POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION, REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE, RIGHT, ROLLBACK SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE, STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING, SUM, SUSPEND TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE, TO, TRAILING, TRANSACTION, TRIGGER, TRIM UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE YEAR OPERATORS: , -, *, /, <>, <, >, ,(comma), =, <=, >=, ~=, !=, ^=, (, ) | |
Странный Microsoft IIS или SSI своими руками
| Раздел Сокровищница |
Server Side Include (SSI) полезная и удобная вещь. Только вот почему-то ограничены ее возможности в IIS всего несколькими директивами. И тем более странно ведет себя #exec если в качестве выполнимого скрипта подставить ISAPI написанную на Delphi.
Ошибки выдаются разные, но смысл их один - Не могу выполнить скрипт, файл не найден :-( Данные мучения в связке IIS 5.0, Windows 2000 Prof, Delphi 6 Enterprise продолжались несколько дней, пока не родилась мысль написать свой SSI.
Задача:Написать свой SSI. Условия:Имеем Microsoft IIS 5.0, Delphi Решение: ШАГ 1. Создание DLL которая служит интерпретатором SSI. Для этого в Delphi меню File/New/Other... Выбираем
В созданном WebModule добавляем одну Action Устанавливаем ее свойство Default:=True.
Создаем обработчик события OnAction. Туда можно вставить например следующий код var i: TStringList; begin i:=TStringList.Create; i.LoadFromFile(Request.PathTranslated); Response.Content:= i.Text+ Request.PathTranslated; end; или такой var i: TStringList; begin Response.Content:= 'Пользователь запросил файл: ' + Request.PathTranslated; end; Компилируем модуль.
Полученную DLL можно уложить в директорий C:\WINNT\system32\inetsrv\ ШАГ 2. Настройка IIS.
С помощью свойств объекта Request можно получить локальное имя запрашиваемого файла: Request.PathTranslated (Например c:\winnt\demo.html).
Также в свойствам данного объекта доступна куча другой информации (см. Help).
А где же SSI спросит Читатель?
Так вот же! У Вас есть координаты запрашиваемого файла, с помощью средств Delphi обрабатывайте его и отсылайте клиенту.
Кстати используя данную технологию возможно создание очень интересной модели, когда файла самого на диске нет, а запрос пользователя используется только для поиска самого файла в базе данных.
А если взглянуть на это чуть шире - ведь это путь создания динамического WWW-сайта с помощью одной DLL... ;-)
Пащенко Андрей (Big Bibigon)
Архангельск, 2002.
Структура формул
Любая формула должна быть составлена с учетов некоторых правил, а также при ее составления необходимо знать из чего она может состоять. Функции, типы, а также другие составляющие приведены ниже:Например: "bool (2 log 4) = (4 sqrt 2) or (bool (2 * 2) = 4)". В формуле каждая функция должна быть заключена в круглые скобки. Что является функцией, а что нет можно узнать вышеприведенного списка. Как я уже сказал, логические выражения в некоторых случаях могут возвращать числовые значения. Это работает только в том случае, если выражение заключено в скобки, например: "bool (bool true) = 1". Логические выражения возвращающие истину принимают значение 1, а содержащие ложь - 0.
Структура сценария
Как уже было сказано, формула переводится в цифровой вид - сценарий. Существуют два вида сценариев - математический и логический. Математический сценарий может содержать внутри себя только математические сценарии, в то время как логический сценарий может содержать внутри себя как логические, так и математическии сценарии. Они по своей структуре очень близки друг к другу. У каждого сценария есть заголовок, который содерит некоторую начальную информацию:
Кстати, в логическом сценарии результат занимает 4 байта и содержит логическое выражение. Это, конечно, очень нерационально тратить целых 4 байта на хранение логической переменной, но так проще. А основное внимание при создании этого модуля я уделял на достижении максимальной скорости вычисления формулы. Работа внутри модуля производится с вещественными числами, что, например, позволяет без проблем использовать тригонометрические функции. При расчете сценария сначала происходит расчет всех вложенных сценариев, в которых, в свою очередь, также происходит расчет вложенных сценариев и так далее. После расчета вложенного сценария в его начало записывается результат. Адреса вложенных сценариев задаются в байтах относительно начала содержащего их сценария. Сама формула при переводе в сценарий делится на части (единицы), которые определяются наличием положительго или отрицательного знака (в случае с логическим сценарием деление на единицы происходит несколько иначе, формула разбивается по логическим операндам xor, or, and).
Единицы содержат в себе 3 составляющие: функции, числа и вложенные сценарии. Это также справедливо и для логического сценария. Функции классифицируются между собой. Они отличаются тем, что некоторые требуют до себя параметр (например факториал: "10!"), некоторые требуют после себя параметр (например косинус: "cos 0"), некоторые требуют и до и после себя параметры (например умножение: "2 * 2"), некоторые не требуют вообще никаких параметров (например число пи: "pi"). У них также есть общее свойство - они все возвращают какой-то результат. Это также касается и логических функций. Каждая единица начинается с заголовка:
Суть действий модуля
В памяти, соответствующей переменной типа "массив байтов", создается машинный код, соответствующий входной строке, после чего переменной типа "function:extended" присваивается адрес начала массива.Свойство Filter
Свойство Filter компонента TTable позволяет задать критерий фильтрации. В этом случае база будет отфильтрована, как только свойство Filtered будет равно TRUE. Синтаксис описания критерия похож на синтаксис секции WHERE SQL-запроса с тем исключением, что имена переменных программы указывать нельзя, можно указывать имена полей и литералы (явно заданные значения); можно использовать обычные операции отношения и логические операторы AND, NOT и OR, например:Эта запись фильтра оставит в таблице записи, в которых поля Doljnost='доцент' и TabNum больше 3000
| Filter:=([Doljnost]='доцент') and ([TabNum] > 3000); Filtered:=True; |
Строку критерия фильтрации можно ввести во время прогона программы или на этапе конструирования. Например, с помощью такого обработчика события OnChecked компонента CheckBox1 критерий фильтрации считывается из поля Edit1 и помещается в свойство Filter компонента Table1:
| procedure TForm1.CheckBox1Click(Sender: TObject); begin Table1.Filter := Edit1.Text; Table1.Filtered := CheckBox1.Checked; end; |
С помощью свойства
| type TFilterOption = (foCaseInsensitive, foNoPartialCompare); property FilterOptions: TFilterOptions; |
можно определить дополнительные свойства фильтрации строковых полей:
foCaseInsensitive - фильтрация производится без учетра разницы регистра
foNoPartialCompare - поиск производится на точное соответствие.
Так зачем же это нужно.
В силу своей огромной нескромности я полагаю, что кому-нибудь это все может быть интересно как пример непосредственного формирования кода в памяти и его исполнения.Техническая документация - список ошибок BDE
| Раздел Сокровищница | источник информации: |
| |
Примечание: Можно использовать DbiGetErrorString() для получения текста любой ошибки.
Список ошибок:
System Related (Fatal Error) 8449 : $2101 : Cannot open a system file. 8450 : $2102 : I/O error on a system file. 8451 : $2103 : Data structure corruption. 8452 : $2104 : Cannot find Engine configuration file. 8453 : $2105 : Cannot write to Engine configuration file. 8454 : $2106 : Cannot initialize with different configuration file. 8455 : $2107 : System has been illegally re-entered. 8456 : $2108 : Cannot locate IDAPI32 .DLL. 8457 : $2109 : Cannot load IDAPI32 .DLL. 8458 : $210A : Cannot load an IDAPI service library. 8459 : $210B : Cannot create or open temporary file. 8460 : $210C : Trying to load multiple IDAPIxx.DLL 8461 : $210D : Shared Memory Conflict Object of Interest not Found 8705 : $2201 : At beginning of table. 8706 : $2202 : At end of table. 8707 : $2203 : Record moved because key value changed. 8708 : $2204 : Record/Key deleted. 8709 : $2205 : No current record. 8710 : $2206 : Could not find record. 8711 : $2207 : End of BLOB. 8712 : $2208 : Could not find object. 8713 : $2209 : Could not find family member. 8714 : $220A : BLOB file is missing. 8715 : $220B : Could not find language driver. Physical Data Corruption 8961 : $2301 : Corrupt table/index header. 8962 : $2302 : Corrupt file - other than header. 8963 : $2303 : Corrupt Memo/BLOB file. 8965 : $2305 : Corrupt index. 8966 : $2306 : Corrupt lock file. 8967 : $2307 : Corrupt family file. 8968 : $2308 : Corrupt or missing .VAL file. 8969 : $2309 : Foreign index file format. I/O related error 9217 : $2401 : Read failure. 9218 : $2402 : Write failure. 9219 : $2403 : Cannot access directory. 9220 : $2404 : File Delete operation failed. 9221 : $2405 : Cannot access file. 9222 : $2406 : Access to table disabled because of previous error. Resource or Limit error 9473 : $2501 : Insufficient memory for this operation. 9474 : $2502 : Not enough file handles. 9475 : $2503 : Insufficient disk space. 9476 : $2504 : Temporary table resource limit. 9477 : $2505 : Record size is too big for table. 9478 : $2506 : Too many open cursors. 9479 : $2507 : Table is full. 9480 : $2508 : Too many sessions from this workstation. 9481 : $2509 : Serial number limit (Paradox). 9482 : $250A : Some internal limit (see context). 9483 : $250B : Too many open tables. 9484 : $250C : Too many cursors per table. 9485 : $250D : Too many record locks on table. 9486 : $250E : Too many clients. 9487 : $250F : Too many indexes on table. 9488 : $2510 : Too many sessions. 9489 : $2511 : Too many open databases. 9490 : $2512 : Too many passwords. 9491 : $2513 : Too many active drivers. 9492 : $2514 : Too many fields in Table Create. 9493 : $2515 : Too many table locks. 9494 : $2516 : Too many open BLOBs. 9495 : $2517 : Lock file has grown too large. 9496 : $2518 : Too many open queries. 9497 : $2519 : Too many threads for client. 9498 : $251A : Too many BLOBs. 9499 : $251B : File name is too long for a Paradox version 5.0 table. 9500 : $251C : Row fetch limit exceeded. 9501 : $251D : Long name not allowed for this tablelevel. 9502 : $251E : Insufficient shared memory available. Integrity Violation 9729 : $2601 : Key violation. 9730 : $2602 : Minimum validity check failed. 9731 : $2603 : Maximum validity check failed. 9732 : $2604 : Field value required. 9733 : $2605 : Master record missing. 9734 : $2606 : Master has detail records. Cannot delete or modify. 9735 : $2607 : Master table level is incorrect. 9736 : $2608 : Field value out of lookup table range. 9737 : $2609 : Lookup Table Open operation failed. 9738 : $260A : Detail Table Open operation failed. 9739 : $260B : Master Table Open operation failed. 9740 : $260C : Field is blank. 9741 : $260D : Link to master table already defined. 9742 : $260E : Master table is open. 9743 : $260F : Detail table(s) exist. 9744 : $2610 : Master has detail records. Cannot empty it. 9745 : $2611 : Self referencing referential integrity must be entered one at a time with no other changes to the table 9746 : $2612 : Detail table is open. 9747 : $2613 : Cannot make this master a detail of another table if its details are not empty. 9748 : $2614 : Referential integrity fields must be indexed. 9749 : $2615 : A table linked by referential integrity requires password to open. 9750 : $2616 : Field(s) linked to more than one master. 9751 : $2617 : Expression validity check failed. Invalid Request 9985 : $2701 : Number is out of range. 9986 : $2702 : Invalid parameter. 9987 : $2703 : Invalid file name. 9988 : $2704 : File does not exist. 9989 : $2705 : Invalid option. 9990 : $2706 : Invalid handle to the function. 9991 : $2707 : Unknown table type. 9992 : $2708 : Cannot open file. 9993 : $2709 : Cannot redefine primary key. 9994 : $270A : Cannot change this RINTDesc. 9995 : $270B : Foreign and primary key do not match. 9996 : $270C : Invalid modify request. 9997 : $270D : Index does not exist. 9998 : $270E : Invalid offset into the BLOB. 9999 : $270F : Invalid descriptor number. 10000 : $2710 : Invalid field type. 10001 : $2711 : Invalid field descriptor. 10002 : $2712 : Invalid field transformation. 10003 : $2713 : Invalid record structure. 10004 : $2714 : Invalid descriptor. 10005 : $2715 : Invalid array of index descriptors. 10006 : $2716 : Invalid array of validity check descriptors. 10007 : $2717 : Invalid array of referential integrity descriptors. 10008 : $2718 : Invalid ordering of tables during restructure. 10009 : $2719 : Name not unique in this context. 10010 : $271A : Index name required. 10011 : $271B : Invalid session handle. 10012 : $271C : invalid restructure operation. 10013 : $271D : Driver not known to system. 10014 : $271E : Unknown database. 10015 : $271F : Invalid password given. 10016 : $2720 : No callback function. 10017 : $2721 : Invalid callback buffer length. 10018 : $2722 : Invalid directory. 10019 : $2723 : Translate Error. Value out of bounds. 10020 : $2724 : Cannot set cursor of one table to another. 10021 : $2725 : Bookmarks do not match table. 10022 : $2726 : Invalid index/tag name. 10023 : $2727 : Invalid index descriptor. 10024 : $2728 : Table does not exist. 10025 : $2729 : Table has too many users. 10026 : $272A : Cannot evaluate Key or Key does not pass filter condition. 10027 : $272B : Index already exists. 10028 : $272C : Index is open. 10029 : $272D : Invalid BLOB length. 10030 : $272E : Invalid BLOB handle in record buffer. 10031 : $272F : Table is open. 10032 : $2730 : Need to do (hard) restructure. 10033 : $2731 : Invalid mode. 10034 : $2732 : Cannot close index. 10035 : $2733 : Index is being used to order table. 10036 : $2734 : Unknown user name or password. 10037 : $2735 : Multi-level cascade is not supported. 10038 : $2736 : Invalid field name. 10039 : $2737 : Invalid table name. 10040 : $2738 : Invalid linked cursor expression. 10041 : $2739 : Name is reserved. 10042 : $273A : Invalid file extension. 10043 : $273B : Invalid language Driver. 10044 : $273C : Alias is not currently opened. 10045 : $273D : Incompatible record structures. 10046 : $273E : Name is reserved by DOS. 10047 : $273F : Destination must be indexed. 10048 : $2740 : Invalid index type 10049 : $2741 : Language Drivers of Table and Index do not match 10050 : $2742 : Filter handle is invalid 10051 : $2743 : Invalid Filter 10052 : $2744 : Invalid table create request 10053 : $2745 : Invalid table delete request 10054 : $2746 : Invalid index create request 10055 : $2747 : Invalid index delete request 10056 : $2748 : Invalid table specified 10058 : $274A : Invalid Time. 10059 : $274B : Invalid Date. 10060 : $274C : Invalid Datetime 10061 : $274D : Tables in different directories 10062 : $274E : Mismatch in the number of arguments 10063 : $274F : Function not found in service library. 10064 : $2750 : Must use baseorder for this operation. 10065 : $2751 : Invalid procedure name 10066 : $2752 : The field map is invalid. Locking/Contention related 10241 : $2801 : Record locked by another user. 10242 : $2802 : Unlock failed. 10243 : $2803 : Table is busy. 10244 : $2804 : Directory is busy. 10245 : $2805 : File is locked. 10246 : $2806 : Directory is locked. 10247 : $2807 : Record already locked by this session. 10248 : $2808 : Object not locked. 10249 : $2809 : Lock time out. 10250 : $280A : Key group is locked. 10251 : $280B : Table lock was lost. 10252 : $280C : Exclusive access was lost. 10253 : $280D : Table cannot be opened for exclusive use. 10254 : $280E : Conflicting record lock in this session. 10255 : $280F : A deadlock was detected. 10256 : $2810 : A user transaction is already in progress. 10257 : $2811 : No user transaction is currently in progress. 10258 : $2812 : Record lock failed. 10259 : $2813 : Couldn't perform the edit because another user changed the record. 10260 : $2814 : Couldn't perform the edit because another user deleted or moved the record. Access Violation - Security related 10497 : $2901 : Insufficient field rights for operation. 10498 : $2902 : Insufficient table rights for operation. Password required. 10499 : $2903 : Insufficient family rights for operation. 10500 : $2904 : This directory is read only. 10501 : $2905 : Database is read only. 10502 : $2906 : Trying to modify read-only field. 10503 : $2907 : Encrypted dBASE tables not supported. 10504 : $2908 : Insufficient SQL rights for operation. Invalid context 10753 : $2A01 : Field is not a BLOB. 10754 : $2A02 : BLOB already opened. 10755 : $2A03 : BLOB not opened. 10756 : $2A04 : Operation not applicable. 10757 : $2A05 : Table is not indexed. 10758 : $2A06 : Engine not initialized. 10759 : $2A07 : Attempt to re-initialize Engine. 10760 : $2A08 : Attempt to mix objects from different sessions. 10761 : $2A09 : Paradox driver not active. 10762 : $2A0A : Driver not loaded. 10763 : $2A0B : Table is read only. 10764 : $2A0C : No associated index. 10765 : $2A0D : Table(s) open. Cannot perform this operation. 10766 : $2A0E : Table does not support this operation. 10767 : $2A0F : Index is read only. 10768 : $2A10 : Table does not support this operation because it is not uniquely indexed. 10769 : $2A11 : Operation must be performed on the current session. 10770 : $2A12 : Invalid use of keyword. 10771 : $2A13 : Connection is in use by another statement. 10772 : $2A14 : Passthrough SQL connection must be shared Os Error not handled by Idapi 11009 : $2B01 : Invalid function number. 11010 : $2B02 : File or directory does not exist. 11011 : $2B03 : Path not found. 11012 : $2B04 : Too many open files. You may need to increase MAXFILEHANDLE limit in IDAPI configuration. 11013 : $2B05 : Permission denied. 11014 : $2B06 : Bad file number. 11015 : $2B07 : Memory blocks destroyed. 11016 : $2B08 : Not enough memory. 11017 : $2B09 : Invalid memory block address. 11018 : $2B0A : Invalid environment. 11019 : $2B0B : Invalid format. 11020 : $2B0C : Invalid access code. 11021 : $2B0D : Invalid data. 11023 : $2B0F : Device does not exist. 11024 : $2B10 : Attempt to remove current directory. 11025 : $2B11 : Not same device. 11026 : $2B12 : No more files. 11027 : $2B13 : Invalid argument. 11028 : $2B14 : Argument list is too long. 11029 : $2B15 : Execution format error. 11030 : $2B16 : Cross-device link. 11041 : $2B21 : Math argument. 11042 : $2B22 : Result is too large. 11043 : $2B23 : File already exists. 11047 : $2B27 : Unknown internal operating system error. 11058 : $2B32 : Share violation. 11059 : $2B33 : Lock violation. 11060 : $2B34 : Critical DOS Error. 11061 : $2B35 : Drive not ready. 11108 : $2B64 : Not exact read/write. 11109 : $2B65 : Operating system network error. 11110 : $2B66 : Error from NOVELL file server. 11111 : $2B67 : NOVELL server out of memory. 11112 : $2B68 : Record already locked by this workstation. 11113 : $2B69 : Record not locked. Network related 11265 : $2C01 : Network initialization failed. 11266 : $2C02 : Network user limit exceeded. 11267 : $2C03 : Wrong .NET file version. 11268 : $2C04 : Cannot lock network file. 11269 : $2C05 : Directory is not private. 11270 : $2C06 : Directory is controlled by other .NET file. 11271 : $2C07 : Unknown network error. 11272 : $2C08 : Not initialized for accessing network files. 11273 : $2C09 : SHARE not loaded. It is required to share local files. 11274 : $2C0A : Not on a network. Not logged in or wrong network driver. 11275 : $2C0B : Lost communication with SQL server. 11277 : $2C0D : Cannot locate or connect to SQL server. 11278 : $2C0E : Cannot locate or connect to network server. Optional parameter related 11521 : $2D01 : Optional parameter is required. 11522 : $2D02 : Invalid optional parameter. Query related 11777 : $2E01 : obsolete 11778 : $2E02 : obsolete 11779 : $2E03 : Ambiguous use of ! (inclusion operator). 11780 : $2E04 : obsolete 11781 : $2E05 : obsolete 11782 : $2E06 : A SET operation cannot be included in its own grouping. 11783 : $2E07 : Only numeric and date/time fields can be averaged. 11784 : $2E08 : Invalid expression. 11785 : $2E09 : Invalid OR expression. 11786 : $2E0A : obsolete 11787 : $2E0B : bitmap 11788 : $2E0C : CALC expression cannot be used in INSERT, DELETE, CHANGETO and SET rows. 11789 : $2E0D : Type error in CALC expression. 11790 : $2E0E : CHANGETO can be used in only one query form at a time. 11791 : $2E0F : Cannot modify CHANGED table. 11792 : $2E10 : A field can contain only one CHANGETO expression. 11793 : $2E11 : A field cannot contain more than one expression to be inserted. 11794 : $2E12 : obsolete 11795 : $2E13 : CHANGETO must be followed by the new value for the field. 11796 : $2E14 : Checkmark or CALC expressions cannot be used in FIND queries. 11797 : $2E15 : Cannot perform operation on CHANGED table together with a CHANGETO query. 11798 : $2E16 : chunk 11799 : $2E17 : More than 255 fields in ANSWER table. 11800 : $2E18 : AS must be followed by the name for the field in the ANSWER table. 11801 : $2E19 : DELETE can be used in only one query form at a time. 11802 : $2E1A : Cannot perform operation on DELETED table together with a DELETE query. 11803 : $2E1B : Cannot delete from the DELETED table. 11804 : $2E1C : Example element is used in two fields with incompatible types or with a BLOB. 11805 : $2E1D : Cannot use example elements in an OR expression. 11806 : $2E1E : Expression in this field has the wrong type. 11807 : $2E1F : Extra comma found. 11808 : $2E20 : Extra OR found. 11809 : $2E21 : One or more query rows do not contribute to the ANSWER. 11810 : $2E22 : FIND can be used in only one query form at a time. 11811 : $2E23 : FIND cannot be used with the ANSWER table. 11812 : $2E24 : A row with GROUPBY must contain SET operations. 11813 : $2E25 : GROUPBY can be used only in SET rows. 11814 : $2E26 : Use only INSERT, DELETE, SET or FIND in leftmost column. 11815 : $2E27 : Use only one INSERT, DELETE, SET or FIND per line. 11816 : $2E28 : Syntax error in expression. 11817 : $2E29 : INSERT can be used in only one query form at a time. 11818 : $2E2A : Cannot perform operation on INSERTED table together with an INSERT query. 11819 : $2E2B : INSERT, DELETE, CHANGETO and SET rows may not be checked. 11820 : $2E2C : Field must contain an expression to insert (or be blank). 11821 : $2E2D : Cannot insert into the INSERTED table. 11822 : $2E2E : Variable is an array and cannot be accessed. 11823 : $2E2F : Label 11824 : $2E30 : Rows of example elements in CALC expression must be linked. 11825 : $2E31 : Variable name is too long. 11826 : $2E32 : Query may take a long time to process. 11827 : $2E33 : Reserved word or one that can't be used as a variable name. 11828 : $2E34 : Missing comma. 11829 : $2E35 : Missing ). 11830 : $2E36 : Missing right quote. 11831 : $2E37 : Cannot specify duplicate column names. 11832 : $2E38 : Query has no checked fields. 11833 : $2E39 : Example element has no defining occurrence. 11834 : $2E3A : No grouping is defined for SET operation. 11835 : $2E3B : Query makes no sense. 11836 : $2E3C : Cannot use patterns in this context. 11837 : $2E3D : Date does not exist. 11838 : $2E3E : Variable has not been assigned a value. 11839 : $2E3F : Invalid use of example element in summary expression. 11840 : $2E40 : Incomplete query statement. Query only contains a SET definition. 11841 : $2E41 : Example element with ! makes no sense in expression. 11842 : $2E42 : Example element cannot be used more than twice with a ! query. 11843 : $2E43 : Row cannot contain expression. 11844 : $2E44 : obsolete 11845 : $2E45 : obsolete 11846 : $2E46 : No permission to insert or delete records. 11847 : $2E47 : No permission to modify field. 11848 : $2E48 : Field not found in table. 11849 : $2E49 : Expecting a column separator in table header. 11850 : $2E4A : Expecting a column separator in table. 11851 : $2E4B : Expecting column name in table. 11852 : $2E4C : Expecting table name. 11853 : $2E4D : Expecting consistent number of columns in all rows of table. 11854 : $2E4E : Cannot open table. 11855 : $2E4F : Field appears more than once in table. 11856 : $2E50 : This DELETE, CHANGE or INSERT query has no ANSWER. 11857 : $2E51 : Query is not prepared. Properties unknown. 11858 : $2E52 : DELETE rows cannot contain quantifier expression. 11859 : $2E53 : Invalid expression in INSERT row. 11860 : $2E54 : Invalid expression in INSERT row. 11861 : $2E55 : Invalid expression in SET definition. 11862 : $2E56 : row use 11863 : $2E57 : SET keyword expected. 11864 : $2E58 : Ambiguous use of example element. 11865 : $2E59 : obsolete 11866 : $2E5A : obsolete 11867 : $2E5B : Only numeric fields can be summed. 11868 : $2E5C : Table is write protected. 11869 : $2E5D : Token not found. 11870 : $2E5E : Cannot use example element with ! more than once in a single row. 11871 : $2E5F : Type mismatch in expression. 11872 : $2E60 : Query appears to ask two unrelated questions. 11873 : $2E61 : Unused SET row. 11874 : $2E62 : INSERT, DELETE, FIND, and SET can be used only in the leftmost column. 11875 : $2E63 : CHANGETO cannot be used with INSERT, DELETE, SET or FIND. 11876 : $2E64 : Expression must be followed by an example element defined in a SET. 11877 : $2E65 : Lock failure. 11878 : $2E66 : Expression is too long. 11879 : $2E67 : Refresh exception during query. 11880 : $2E68 : Query canceled. 11881 : $2E69 : Unexpected Database Engine error. 11882 : $2E6A : Not enough memory to finish operation. 11883 : $2E6B : Unexpected exception. 11884 : $2E6C : Feature not implemented yet in query. 11885 : $2E6D : Query format is not supported. 11886 : $2E6E : Query string is empty. 11887 : $2E6F : Attempted to prepare an empty query. 11888 : $2E70 : Buffer too small to contain query string. 11889 : $2E71 : Query was not previously parsed or prepared. 11890 : $2E72 : Function called with bad query handle. 11891 : $2E73 : QBE syntax error. 11892 : $2E74 : Query extended syntax field count error. 11893 : $2E75 : Field name in sort or field clause not found. 11894 : $2E76 : Table name in sort or field clause not found. 11895 : $2E77 : Operation is not supported on BLOB fields. 11896 : $2E78 : General BLOB error. 11897 : $2E79 : Query must be restarted. 11898 : $2E7A : Unknown answer table type. 11926 : $2E96 : Blob cannot be used as grouping field. 11927 : $2E97 : Query properties have not been fetched. 11928 : $2E98 : Answer table is of unsuitable type. 11929 : $2E99 : Answer table is not yet supported under server alias. 11930 : $2E9A : Non-null blob field required. Can't insert records 11931 : $2E9B : Unique index required to perform changeto 11932 : $2E9C : Unique index required to delete records 11933 : $2E9D : Update of table on the server failed. 11934 : $2E9E : Can't process this query remotely. 11935 : $2E9F : Unexpected end of command. 11936 : $2EA0 : Parameter not set in query string. 11937 : $2EA1 : Query string is too long. 11946 : $2EAA : No such table or correlation name. 11947 : $2EAB : Expression has ambiguous data type. 11948 : $2EAC : Field in order by must be in result set. 11949 : $2EAD : General parsing error. 11950 : $2EAE : Record or field constraint failed. 11951 : $2EAF : When GROUP BY exists, every simple field in projectors must be in GROUP BY. 11952 : $2EB0 : User defined function is not defined. 11953 : $2EB1 : Unknown error from User defined function. 11954 : $2EB2 : Single row subquery produced more than one row. 11955 : $2EB3 : Expressions in group by are not supported. 11956 : $2EB4 : Queries on text or ascii tables is not supported. 11957 : $2EB5 : ANSI join keywords USING and NATURAL are not supported in this release. 11958 : $2EB6 : SELECT DISTINCT may not be used with UNION unless UNION ALL is used. 11959 : $2EB7 : GROUP BY is required when both aggregate and non-aggregate fields are used in result set. 11960 : $2EB8 : INSERT and UPDATE operations are not supported on autoincrement field type. 11961 : $2EB9 : UPDATE on Primary Key of a Master Table may modify more than one record. 11962 : $2EBA : Queries on MS ACCESS tables are not supported by local query engines. 11963 : $2EBB : Preparation of field-level constraint failed. 11964 : $2EBC : Preparation of field default failed. 11965 : $2EBD : Preparation of record-level constraint failed. 11972 : $2EC4 : Constraint Failed. Expression: Version Mismatch Category 12033 : $2F01 : Interface mismatch. Engine version different. 12034 : $2F02 : Index is out of date. 12035 : $2F03 : Older version (see context). 12036 : $2F04 : .VAL file is out of date. 12037 : $2F05 : BLOB file version is too old. 12038 : $2F06 : Query and Engine DLLs are mismatched. 12039 : $2F07 : Server is incompatible version. 12040 : $2F08 : Higher table level required Capability not supported 12289 : $3001 : Capability not supported. 12290 : $3002 : Not implemented yet. 12291 : $3003 : SQL replicas not supported. 12292 : $3004 : Non-blob column in table required to perform operation. 12293 : $3005 : Multiple connections not supported. 12294 : $3006 : Full dBASE expressions not supported. 12295 : $3007 : Nested transactions not supported. System configuration error 12545 : $3101 : Invalid database alias specification. 12546 : $3102 : Unknown database type. 12547 : $3103 : Corrupt system configuration file. 12548 : $3104 : Network type unknown. 12549 : $3105 : Not on the network. 12550 : $3106 : Invalid configuration parameter. Warnings 12801 : $3201 : Object implicitly dropped. 12802 : $3202 : Object may be truncated. 12803 : $3203 : Object implicitly modified. 12804 : $3204 : Should field constraints be checked? 12805 : $3205 : Validity check field modified. 12806 : $3206 : Table level changed. 12807 : $3207 : Copy linked tables? 12809 : $3209 : Object implicitly truncated. 12810 : $320A : Validity check will not be enforced. 12811 : $320B : Multiple records found, but only one was expected. 12812 : $320C : Field will be trimmed, cannot put master records into PROBLEM table. Miscellaneous 13057 : $3301 : File already exists. 13058 : $3302 : BLOB has been modified. 13059 : $3303 : General SQL error. 13060 : $3304 : Table already exists. 13061 : $3305 : Paradox 1.0 tables are not supported. 13062 : $3306 : Update aborted. Compatibility related 13313 : $3401 : Different sort order. 13314 : $3402 : Directory in use by earlier version of Paradox. 13315 : $3403 : Needs Paradox 3.5-compatible language driver. Data Repository related 13569 : $3501 : Data Dictionary is corrupt 13570 : $3502 : Data Dictionary Info Blob corrupted 13571 : $3503 : Data Dictionary Schema is corrupt 13572 : $3504 : Attribute Type exists 13573 : $3505 : Invalid Object Type 13574 : $3506 : Invalid Relation Type 13575 : $3507 : View already exists 13576 : $3508 : No such View exists 13577 : $3509 : Invalid Record Constraint 13578 : $350A : Object is in a Logical DB 13579 : $350B : Dictionary already exists 13580 : $350C : Dictionary does not exist 13581 : $350D : Dictionary database does not exist 13582 : $350E : Dictionary info is out of date - needs Refresh 13584 : $3510 : Invalid Dictionary Name 13585 : $3511 : Dependent Objects exist 13586 : $3512 : Too many Relationships for this Object Type 13587 : $3513 : Relationships to the Object exist 13588 : $3514 : Dictionary Exchange File is corrupt 13589 : $3515 : Dictionary Exchange File Version mismatch 13590 : $3516 : Dictionary Object Type Mismatch 13591 : $3517 : Object exists in Target Dictionary 13592 : $3518 : Cannot access Data Dictionary 13593 : $3519 : Cannot create Data Dictionary 13594 : $351A : Cannot open Database Driver related 15873 : $3E01 : Wrong driver name. 15874 : $3E02 : Wrong system version. 15875 : $3E03 : Wrong driver version. 15876 : $3E04 : Wrong driver type. 15877 : $3E05 : Cannot load driver. 15878 : $3E06 : Cannot load language driver. 15879 : $3E07 : Vendor initialization failed. 15880 : $3E08 : Your application is not enabled for use with this driver.ТЕХНОЛОГИЯ DCOM
Настройка системы безопасности DCOM сервера Как я понял, основная проблема в DCOM, с которой сталкиваются разработчики - настройка системы безопасности. Далее описано, как были сделаны настройки безопасности у меня.Создана группа, в которую включены пользователи, которым нужен доступ к данному DCOM серверу (назовем ее DCOM_DEBUG).
В DCOMCNFG : (это было добавлено и на сервере и на клиенте) DefaultSecurity -> Default Access Permissions DCOM_DEBUG: Allow Access SYSTEM: Allow Access Everyone: Allow Access 2.DefaultSecurity -> Default Launch Permissions DCOM_DEBUG: Allow Launch SYSTEM: Allow Launch INTERACTIVE: Allow Launch Everyone: Allow Launch 3.DefaultSecurity -> Default Configuration Permissions SYSTEM: Full Control DCOM_DEBUG: Full Control Everyone: Full Control Установка этих параметров необходима, по-моему, потому, что контекст безопасности интерфейса передаваемого на сервер для нотификации клиента берется из установок по умолчанию.
Только на сервере.
Установки параметров безопасности для объекта были установлены точно такие же, за исключением того, что Everyone включена не была. На вкладке Identity был выбран пользователь, от имени которого запускается COM сервер. Одна тонкость: у пользователя, от имени которого запускается COM сервер должно быть право "Log on as batch job", иначе сервер не запустится (это право было дано всей группе DCOM_DEBUG). Если выбрать Interactive User, то сервер не запустится, в том случае если пользователь делает Logoff. В случае с Launching User происходили какие-то невнятные проблемы (видимо это было связано со спецификой решаемой мной задачи - DCOM сервер с поддержкой множественных клиентских соединений).
Алексей Вуколов
Статьи по теме:
TExcelManager
Компонент предназначен для работы с таблицами Excel. Он позволяет находить любые таблицы в любом месте документа Excel и импортировать их в таблицы компонента TTable. Можно также экспортировать таблицы из TTable в документы Excel. Существует две версии компонента - для Microsoft Office 2000 и для Microsoft Office XP.
TPrintService
Комментарий Дмитрия Васильева: Как было уже сказано: Компонент предназначен для реализации всех функций, связанных с выводом на печать: выбор принтера, его настройка, предварительный просмотр и собственно печать.Ключевым событием для TPrintService является OnDraw(Sender: TObject; Canvas: TCanvas; PageNumber: Integer; DrawTarget: TDrawTarget), где TDrawTarget = (dtPreview, dtPrint). Именно в этом событии производится определение содержимого документа. В минимальном варианте использования компонента пользователю достаточно определить только это событие. При выводе должны использоваться свойства PageWidth и PageHeight объекта Printer для определения ширины и высоты листа. Преобразование координат для предварительного просмотра происходит без участия пользователя. Все, что нужно сделать, это вывести изображение на передаваемую Canvas в масштабе принтера. Шрифты масштабируются автоматически (это уже дело Windows), поэтому, вне зависимости от модели принтера и установленного разрешения, шрифт размером, скажем, 10, будет выглядеть одинаково при печати из CorelDraw, Word97 и PrintService. Следует использовать именно размер шрифта (Size), т.к. высота (Heigth) изменяется в зависимости от текущего разрешения принтера. В PageNumber передается номер страницы. При многостраничной печати пользователь может определить вывод для всех страниц с номерами 1..PageCount. В DrawTarget содержится информация о том, куда в данный момент производится вывод - в окно предварительного просмотра или на принтер. Эта информация, вообще говоря, не является необходимой, НО, вдруг кому-нибудь захочется проанализировать количество цветов принтера и сделать черно-белый вывод на черно-белый принтер при цветном изображении в окне предварительного просмотра?
Комментарий Алексея Румянцева: Короче говоря, в OnDraw, вы сами определяете то что выводится на принтер (или в окно предварительного просмотра), просто рисуя это на канве.
TRyMenu — собственная отрисовка меню
| Раздел Сокровищница |
| Перестала мне тут на днях нравиться борландовская прорисовка меню... Вот вобщем-то и все что можно сказать о представленном Вашему вниманию классе TRyMenu. Никаких дочерних классов, вешаемся на OnAdvancedDrawItem и далее чисто рисование по канве. Ну а художественные фантазии они у каждого свои и чуть напрягшись на ней(на канве) можно и переливы и пейзаж нарисовать, но кто этим балуется наверняка уже свои классы имеет, а это так минимальный набор для прорисовки меню в новом стиле. Демо прилагается. Написано на Delphi5. Тестировалось на Win98. WinXP. В случае обнаружения ошибки или несовместимости с другими версиями Delphi и Windows, просьба сообщить автору. Ваши вопросы и замечания присылайте. |  |
Скачать проект (10K) 22.04.02
Алексей Румянцев
.
Специально для
TRyPrintService
Основное отличие от TPrintService - это наличие "буфера печати", т.е. вам остается заполнить его содержимым (линиями, прямоугольниками, текстом, картинками...) причем не связывая себя какими-либо рамками (в частности размером и положением или вообще отсутствием необходимого элемента в данном конкретном месте отчета), т.е. каждый лист отчета может быть оформлен по своим правилам или без правил. Весь результат работы хранится в этом "буфере" откуда может быть предворительно просмотрен в окне предварительного просмотра, распечатан, скопирован, сохранен, экспортирован (надеюсь вскоре добраться до этой функции) и т.п. Для этого были созданы специальные объекты (RptRect, RptLine, RptEdit, RptBitmap, список легко может быть расширен), параметры (property) которых заполняются пользовательскими значениями (Left, Top..., Color..., Text и т.д.) в соответствии с которыми будет меняться их положение на странице, цвет, текст и т.д.
RptOбъекты создаются только один раз, после чего у них меняются лишь значения параметров и затем отправляются с новыми значениями в очередь на печать, где и дожидаются своего звездного часа. RptОбъекты могут отправляться в буфер отчета в любой последовательности, в любом кол-ве и с любым положением на странице. В демонстрационном примере показано, как создавать новый отчет, заполнить его некоторой информацией (прямоугольники, текст, картинки); сохранять в файле и загружать из него отчет, а также как вызывать предварительный просмотр и печатать.
Скачать: (193 K)
С уважением, Алексей Румянцев.
Специально для
TRySharedSream — класс упрощающий работу с файлом подкачки
| Раздел Сокровищница |
TSharedStream (версия 1).
Когда-то (кажется год назад) на страницах "королевства" я прочитал статью об использовании файла подкачки как о временном хранилище данных. ( Имеется ввиду статья Дмитрия Логинова ) После этой статьи я заинтересовался работой с Swap'ом.
Некотое время в работе я пользовался чисто FileMappingFun'кциями, что оказалось нудно и трудоемко (не так чтобы очень, но согласитесь, что легче хранить всю информацию в одном месте[классе], чем иметь несколько переменных и помнить когда и как их надо использовать).
Написал первую версию класса-обертки над FileMappingFun'кциями и все как-будто было нормально, но убивало одно НО - не было возможности изменять размер области["страницы"] под данные выделенной при ее создании, т.е. надо было заранее знать размер информации, которую вы собираетесь в нее записать. В TSharedStream я решил эту проблему, плохо или хорошо трудно сказать - по сравнению с невозможностью изменить размер - хорошо, а по качеству реализации - не очень.
Подробнее ...
Прошло н-ное кол-во времени, появилось желание сделать работу класса правильней, действенней, качественней (нужного слова не подобрать).
TSelectableTree - TTreeView с возможностью MultiSelect'а
TSelectableTree - наследник от TCustomTreeView, обладает возможностью множественного выбора ( свойство MultiSelect ).Соответственно дополнительные методы - procedure SelectAll; procedure UnSelectAll; procedure InvertSelection; Свойство DefaultPopup = True назначает для дерева PopUp-меню (по правой кнопке мыши) со следующими пунктами: Отметить все Снять все пометки Инверсия выделения И еще всякие полезные мелочи. Например, очень удобная процедура для обработки каждой ветки дерева: procedure TraverseTree(TreeView: TCustomTreeView; Node: TTreeNode; ATraverseTreeEvent : TTVTraverseEvent; AInfo : Pointer); var CNode: TTreeNode; begin if Assigned(ATraverseTreeEvent) then begin if Node = nil then CNode := TTreeView(TreeView).Items.GetFirstNode else CNode := Node; repeat ATraverseTreeEvent(CNode, AInfo); CNode := CNode.GetNext; until (CNode = nil) or (not CNode.HasAsParent(Node)); end; end;
Скачать исходный код (4 K)
Сергей Королев
TSharedSream — класс упрощающий работу с файлом подкачки
| Раздел Сокровищница |
Когда-то (кажется год назад) на страницах "королевства" я прочитал статью об использовании файла подкачки как временном хранилище данных. ( Имеется ввиду статья Дмитрия Логинова ) После этой статьи я заинтересовался Swap'ом. Некотое время я пользовался чисто File Mapping Func'циями, что оказалось нудно и трудоемко(не так чтобы очень, но согласитесь, что легче хранить всю информацию в одном месте[классе], чем иметь несколько переменных и помнить когда и как их надо использовать).
Написал первую версию класса-обертки над File Mapping Func'циями и все как-будто было нормально, но убивало одно НО - не было возможности изменять размер области["страницы"] под данные выделенной при ее создании, т.е. надо было заранее знать размер информации, которую вы собираетесь в нее записать - в данной версии я считаю что мне удалось обойти это недоразумение (подробности в исходнике).
Итак...
Класс TSharedSream — класс упрощающий работу с файлом подкачки. Более того, скрывающий все сложности обращения к File Mapping Func'циям. Этот класс является потомком TStream, следовательно он наследует его поведение, а изучение работы с ним сводится к внимательному прочтению хелпа по TStream'у.
Описание:
| Раздел Сокровищница | нов, дата публикации 13 февраля 2002г. |
| Компонент TVertGrid представляет собой модифицированный TStringGrid. В стандартный компонент добавлена возможность в режиме Design-time заполнять первую колонку (property Labels) и первую строку (property Titles) грида. Если набранных строк в Labels больше, чем задано количество строк самого TVertGrid, то они будут автоматически добавлены. Аналогично и с количеством колонок (Titles). При уменьшении строк в свойствах Labels и Titles, количество строк и колонок самого грида не будет уменьшаться. На скриншоте показано редактирование списка заголовков колонок. Количество строк в Titles это количество заполненных колонок первой строки. Компонент очень прост и вы можете модифицировать его по своему собственному желанию. |  |
Скачать (1K)
Исходный код компонента:
| unit VertGrid; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, stdctrls; type TVertGrid = class(TStringGrid) protected { Protected declarations } procedure SetLines(Value: TStrings); function GetLines : TStrings; procedure SetTitles(Value: TStrings); function GetTitles : TStrings; public constructor Create(AOwner: TComponent); override; published // Первая колонка property Labels: TStrings read GetLines write SetLines; // Первая строка property Titles: TStrings read GetTitles write SetTitles; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TVertGrid]); end; constructor TVertGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); ColCount := 2; DefaultRowHeight := 16; end; procedure TVertGrid.SetLines(Value: TStrings); begin if Value.Count > RowCount then RowCount := Value.Count; Cols[0].Assign( Value ); end; procedure TVertGrid.SetTitles(Value: TStrings); begin if Value.Count > ColCount then ColCount := Value.Count; Rows[0].Assign( Value ); end; function TVertGrid.GetLines : TStrings; begin result := Cols[0]; end; function TVertGrid.GetTitles : TStrings; begin result := Rows[0]; end; end. |
ULogs.pas
Скачать (2.3 K) unit uLogs; interface uses Classes,Controls,StdCtrls,ComCtrls,Forms; {-------раздел для генерации сообщений----------} {всего одна процедура} procedure (Channel:byte;Mes:String); {номер канала (0 - 255) и текст сообщения} {----------раздел для обработки сообщений----------} Type TChannels = set of byte; TLog = class {абстрактный базовый класс} protected FChannels:TChannels; {множество обрабатываемых каналов} procedure (Channel:byte;Mes:String);virtual;abstract; {InternalToLog - для каждого наследника определяет способ обработки.} {Номер канала передается, чтобы его можно было учесть при обработке,} {например, при выводе диагностических сообщений менять цвет текста} {в зависимости от номера канала} public procedure (Channel:byte;Status:boolean); procedure (Channel:byte;Mes:String);{общий механизм проверки номера канала} constructor Create(AChannels:TChannels); {множество обрабатываемых каналов задается при создании лога} property Channels:TChannels read FChannels write FChannels; {множество обрабатываемых каналов доступно в процессе работы} end; TStringsLog = class(TLog) {добавление строки к содержимому любого наследника абстрактного базового класса TStrings} FStrings:TStrings; {ссылка на объект в который будет добавлена строка} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AStrings:TStrings); end; TFileLog = class(TLog) {добавление строки к содержимому файла} FFile:Text; {имя файла} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;FileName:String); end; TCaptionLog = class(TLog) {вывод текста сообщения в Caption любого компонента - наследника TControl} FControl:TControl; {компонент для отображения} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AControl:TControl); end; TStatusBarLog = class(TLog){вывод текста сообщения в StatusPanel} FStatusPanel:TStatusPanel; procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AStatusPanel:TStatusPanel); end; TMessageBoxLog = class(TLog) {вывод текста сообщения в MessageBox} fCaption:String; fFlags: Longint; procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;Caption:String;Flags: Longint); end; function (ALog:TLog):word; {Регистрация нового лога в списке} function (ALog:TLog;Name:string):integer; {Регистрация нового лога в списке под заданным именем, чтобы можно было его удалить} function (Name:string):integer; {Удаление из списка лога с заданным именем} implementation uses Windows; var LogList:TStrings; lLog:TLog; procedure ToLog(Channel:byte;Mes:String); var i:integer; Begin if LogList.Countthen exit; for i:=0 to LogList.Count-1 do TLog(LogList.Objects[i]).toLog(Channel,Mes); End; function SetLog(ALog:TLog):word;{Регистрация нового лога в списке} Begin result:=LogList.AddObject('',ALog); End; function SetNamedLog(ALog:TLog;Name:string):integer; {Регистрация нового лога в списке под заданным именем, чтобы можно было его удалить} var i:integer; Begin result:=-1; {лог под таким именем уже есть} i:=LogList.IndexOf(Name); if i=-1 then result:=LogList.AddObject(Name,ALog); End; function ReSetNamedLog(Name:string):integer; {Удаление из списка лога с заданным именем} var i:integer; Begin result:=LogList.IndexOf(Name); { -1 если лога под таким именем нет} if result<>-1 then LogList.Delete(result); End; { TLog } constructor TLog.Create(AChannels: TChannels); begin FChannels:=AChannels; end; procedure TLog.SetChannel(Channel: byte; Status: boolean); begin if status then FChannels:=FChannels+[channel] else FChannels:=FChannels-[channel]; end; procedure TLog.toLog(Channel: byte; Mes: String); begin if (Channel in FChannels) then InternalToLog(Channel,Mes); end; { TStringsLog } constructor TStringsLog.Create(AChannels: TChannels; AStrings: TStrings); begin inherited Create(AChannels); FStrings:=AStrings; end; procedure TStringsLog.InternalToLog(Channel: byte; Mes: String); begin FStrings.Add(Mes); end; { TFileLog } constructor TFileLog.Create(AChannels: TChannels; FileName: String); begin inherited Create(AChannels); AssignFile(FFile,FileName); Rewrite(FFile); Writeln(FFile, 'Log file start'); CloseFile(FFile); end; procedure TFileLog.InternalToLog(Channel: byte; Mes: String); begin Append(fFile); Writeln(fFile, mes); Flush(fFile); CloseFile(fFile); end; { TCaptionLog } constructor TCaptionLog.Create(AChannels: TChannels; AControl: TControl); begin inherited Create(AChannels); FControl:=AControl; end; procedure TCaptionLog.InternalToLog(Channel: byte; Mes: String); begin TLabel(FControl).Caption:=Mes; // FControl.Caption:=Mes; end; { TStatusBarLog } constructor TStatusBarLog.Create(AChannels: TChannels; AStatusPanel: TStatusPanel); begin inherited Create(AChannels); FStatusPanel:=AStatusPanel; end; procedure TStatusBarLog.InternalToLog(Channel: byte; Mes: String); begin FStatusPanel.text:=Mes; end; { TMassageBoxLog } constructor TMessageBoxLog.Create(AChannels: TChannels; Caption: String; Flags: Integer); begin inherited create(AChannels); fCaption:=Caption; fFlags:=Flags; end; procedure TMessageBoxLog.InternalToLog(Channel: byte; Mes: String); begin Application.MessageBox(PChar(Mes), PChar(fCaption), fFlags); end; initialization LogList:=TStringList.create; lLog:=TMessageBoxLog.Create([0..5],'Ошибка инициализации', MB_OK); // Каналы с 0 по 5 зарезервированы для ошибок инициализации модулей SetLog(lLog); finalization LogList.free; end.Управление чужим приложением средствами WinAPI
Просмотрев в королевстве на данную тему множество вопросов, оставшихся без ответов, сам нашел решение проблеммы управления чужим приложением. Данный код ищет чужое приложение,запускает в нем 2 пункт 7 подпункт меню, в появившемся диалоге выбора файла ищет класс Edit c текстом '', вводит в класс Edit строку с именем файла и отсылает команду Enter. Далее ищет появление диалогового окна с предложением подтвердить загрузку. После ищет кнопку "Да" и отсылает команду Enter.
Напомню, что все диалоговые окна — это главные окна, которые ищутся FindWindow, а всякие Edit,Button,ComboBox и т.д. - это дочерние окна, которые ищутся функцией FindWindowEx.
| procedure TForm1.Button9Click(Sender: TObject); Var Men :HMenu; Hnd,HndDialog,HndControl,HndAsc,HndBtn :HWnd; HndMen,HndSMen :HMenu; StrClass :PChar; StrBase :string; IdBtn,idMen :integer; begin Hnd:=FindWindow(nil, 'Конфигуратор - 2345'); if Hnd <>0 then begin //фокусируем: windows.SetForegroundWindow(Hnd); //или можно так:windows.BringWindowToTop(Hnd); //Работа с меню: //=============================================================================== HndMen:=GetMenu(Hnd);//получили описатель главного меню окна. HndSMen:=GetSubMenu(HndMen,1);//получили описатель второго пункта главного меню (0 -первый пункт) //получили идентификатор 7 пункта подменюменю (черты в меню - это также пункты) idMen:=GetMenuItemID(HndSMen,6); //в данном случае idMen это word(33206) if idMen<>0 then begin //запускаем пункт меню. Именно PostMessage, SendMessage - не работает. PostMessage(Hnd,WM_COMMAND,idMen,0); //=============================================================================== //Инициализируем переменные диалогов: HndDialog:=0; HndControl:=0; HndBtn:=0; HndAsc:=0; IdBtn:=0; //=============================================================================== //поищем диалог ввода до тех пор пока не найдем: While HndDialog=0 do HndDialog:= FindWindow(nil, 'Открыть файл конфигурации'); if HndDialog<>0 then begin StrClass:='Edit'+#0;//на всякий случай вставим завершающий ноль //Ищем класс Edit среди подчиненных HndDialog окон HndControl:=FindWindowEx(HndDialog,0,StrClass,''); if HndControl<>0 then begin StrBase:='D:\md\zik2345\1Cv7.MD'; Sleep(1000);//а вот без этого ну ни как не хочет работать. SendMessage(HndControl, WM_Settext,0,Integer(StrBase));//все, текст переменной StrBase введен. //жмем Enter SendMessage(HndDialog,WM_Command,MakeWParam(1,$0f),HndControl); //здесь 1 это значит что мы передаем на выполнение акселератор //строки, а $0f - это событие "(Enter)" этому акселератору //в MSDN смотрим WM_Command. //MakeWParam - функция которая два Word слова помещает : //первое в верхние 16 bit, второе в нижние 16 bit, 32 битного(LongInt) //параметра WParam (аналог MakeLParam ). //=============================================================================== //ищем диалог пока не найдем: while HndAsc=0 do HndAsc:= FindWindow(nil, 'Конфигуратор'); if HndAsc<>0 then begin //ищем кнопку в диалоге: //обращаем внимание на знак & - если на кнопку завязана комбинация клавиш //(это когда буква в кнопке подчеркнута) //то надо к имени добавлять перед этой буквой & а то кнопочка не найдется если их несколько. while HndBtn=0 do HndBtn:=FindWindowEx(HndAsc,0,'Button','&Да'); if HndBtn<>0 then begin IdBtn:=GetDlgCtrlID(HndBtn); if IdBtn<>0 then begin //ну и наконец жмем кнопку '&Да': SendMessage(HndAsc,WM_Command,MakeWParam(IdBtn,BN_CLICKED),HndBtn); //а хелп MSDN по BN_CLICKED или WM_Command //здесь верхнее слово WParam это идентификатор контрола, а нижнее - код BN_CLICKED end; end; end; //================================================================================ end; end; end; end; end; |
Userunit
| | "Knowledge itself is power" F.Bacon |
| Функция для представления числа прописью |
Внедрение и линковка компонентов. Пример.
| Раздел Сокровищница | рбань С.В., дата публикации 18 марта 2002г. |
Модуль демонстрирует возможности по "Внедрению" и "Сцепке" компонентов. В основном все д/б понятно из подстрочных комментариев. Для чего нужно: Задача - содать специализированный LightWeight вариант TChart. Работа ведется несколькими программистами. ВСЕ элементы д/б объектами, а по возможности и самостоятельными компонентами. Например - полоса скроллинга по данным. Она должна быть либо "встроенной" (принадлежать базовому компоненту) либо внешней. Причем при работе (в приложении) различий быть не должно...
Первый маленький элемент - полоса скроллинга по данным и контейнер для нее. Компонент вполне самостоятельный и вполне может быть полезен Вне контекста задачи.
Примечания:
Скачать пример: (11 K)
Этот код является плодом обсуждения проблемы на Круглом столе между рем Шевченко.
Горбань С.В.
Специально для
Возможности
Пример: -(x+cosy)/Exp[z]+LN {sin пеРеменная1-tg 3.14}
Возможные проблемы при работе с TCanvas больших размеров
| Рздел Сокровищница | ренко, дата публикации 08 января 2002г. |
Проблема.
Так получилось, что передо мной встала задачи работы с канвой (TCanvas) больших размеров (от 2000 и более точек в одном измерении). Через достаточно короткое время работы я обнаружил, что методы TCanvas иногда ведут себя некорректно. Некорректность поведения заключалась в том, что при определенных условиях графические примитивы, например, прямые линии, либо отображались неправильно, либо просто исчезали. Проверка и перепроверка текста программы ничего не дала. Попытка найти какую-либо информацию о возможных особенностях работы с канвой таких размеров также ни дала положительного результата (может быть, просто плохо искал). Пришлось разбираться самому, а затем и обратиться за советом к некоторым жителям Королевства.
Результат.
В ходе работы удалось некоторым образом локализовать условия возникновения изложенной выше ситуации.
Напрашивающиеся выводы по использованию TCanvas больших размеров.
"Итак, решение одно (во всяком случае, одно я нашел, может решений больше) - используйте платформу NT. Под Windows 2000 все работает НАМНОГО ЛУЧШЕ! Советую просто поменять систему. Если в вашей программе будет ремарка "разработана специально под NT", то это не будет минусом для программы"
P.S.
В качестве примера я предлагаю вашему вниманию небольшой проект , в котором возникают изложенные выше проблемы. Суть проекта - отрисовка разными методами сетки с шагом 40 точек.
К сожалению, мне не удалось подобрать такой режим, чтобы проблема возникало на любой машине, на которой стоит Windows 9x. Поэтому я хотел бы попросить сразу не забрасывать меня помидорами тех, у кого под Windows 9x все будет работать корректно. Возможно, что все вышеописанное является неким частным случаем, и дарность за оказанную помощь.
Специально для
Выключение компьютера в заданное время
| Раздел Сокровищница | Агранович, дата публикации 13 июня 2002г. |
Программа для выключения компьютера в заданное время. Если запустить с параметром, указав время, то программа запустится скрытно и выключит компьютер в указанное время. Проверенно на Windows XP.
Для выключения используется процедура: Procedure ShutdownComputer; var ph:THandle; tp,prevst:TTokenPrivileges; rl:DWORD; begin OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,ph); LookupPrivilegeValue(Nil,'SeShutdownPrivilege',tp.Privileges[0].Luid); tp.PrivilegeCount:=1; tp.Privileges[0].Attributes:=2; AdjustTokenPrivileges(ph,FALSE,tp,SizeOf(prevst),prevst,rl); ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF,0); end; Скачать (обновление от 01.07.02):
WinAPIFAQ
| источник информации: |
| DELPHI WinAPI FAQ Перевод с английского |
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи.
Скачать (27 K) для просмотра в off-line.
Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор совместимый со стандартом EnergyStar.
Отправьте сообщение wm_SysCommand с параметром WParam = SC_MonitorPower и LParam = 0 для отключения монитора LParam = 1 для включения монитора
В приведенном примере монитор отключается на 10 секунд.
Пример: type TForm1 = class(TForm) Button1: TButton; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public MonitorOff : bool; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Timer1.Enabled := false; Timer1.Interval := 10000; MonitorOff := false; end; procedure TForm1.Timer1Timer(Sender: TObject); begin if MonitorOff then begin MonitorOff := false; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); Timer1.Enabled := false; end; end; procedure TForm1.Button1Click(Sender: TObject); begin MonitorOff := true; Timer1.Enabled := true; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); end; Вопрос:
Как создать мигающий заголовок окна (пиктограмму)?
Ответ:
Можно воспользоваться функцией API FlashWindow():
Пример:
var Flash : bool; procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Form1.Handle, Flash); FlashWindow(Application.Handle, Flash); Flash := not Flash; end; procedure TForm1.FormCreate(Sender: TObject); begin Flash := False; end; Вопрос:
Иногда всплывающее меню моего приложения system tray не исчезает когда оно теряет фокус. Как закрыть его?
Ответ:
При показе всплывающего меню установите foreground window, затем пошлите сообщение WM_NULL после показа меню. procedure TForm1.WndProc(var Msg : TMessage); var p : TPoint; begin case Msg.Msg of WM_USER + 1: case Msg.lParam of WM_RBUTTONDOWN: begin SetForegroundWindow(Handle); GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0); end; end; end; inherited; end; Вопрос:
Как узнать текущие время и дату по Гринвичу
Ответ:
Используя API фукцию GetSystemTime.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var lt : TSYSTEMTIME; st : TSYSTEMTIME; begin GetLocalTime(lt); GetSystemTime(st); Memo1.Lines.Add('LocalTime = ' + IntToStr(lt.wmonth) + '/' + IntToStr(lt.wDay) + '/' + IntToStr(lt.wYear) + ' ' + IntToStr(lt.wHour) + ':' + IntToStr(lt.wMinute) + ':' + IntToStr(lt.wSecond)); Memo1.Lines.Add('UTCTime = ' + IntToStr(st.wmonth) + '/' + IntToStr(st.wDay) + '/' + IntToStr(st.wYear) + ' ' + IntToStr(st.wHour) + ':' + IntToStr(st.wMinute) + ':' + IntToStr(st.wSecond)); end; Вопрос:
Какой самый быстрый способ для очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, WHITENESS); end; Вопрос:
При изменении размеров формы мне необходимо чтобы перерисовывалась вся ее поверхность. Но свойство Canvas.ClipRect у формы - только для чтения.
Ответ:
На событии Resize вызовите Windows API функцию InvalidateRect(). Если передать nil в качестве второго параметра приведет к тому, что перерисовываться будет вся клиентская область окна. Третий параметр указывает будет ли перерисовываться фон формы.
Пример:
procedure TForm1.FormResize(Sender: TObject); begin InvalidateRect(Form1.Handle, nil, false); end; Вопрос:
Как использовать процедуру mouse_event() для имитации событий мыши?
Ответ:
Приведенный пример демонстрирует использование API функции mouse_event() для имитации событий мыши. При нажатии кнопки Button2 программа перемещает курсор мыши на кнопку Button1 и щелкает по ней. Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"), где 65535 "Mickeys" равно ширине экрана. procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Button 1 clicked'); end; procedure TForm1.Button2Click(Sender: TObject); var Pt : TPoint; begin {Позволим кнопке Button2 перерисоваться} Application.ProcessMessages; {Найдем координаты центра button 1} Pt.x := Button1.Left + (Button1.Width div 2); Pt.y := Button1.Top + (Button1.Height div 2); {Преобразуем Pt к координатам экрана} Pt := ClientToScreen(Pt); {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки} Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height)); {Переместим курсор мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0); {Имитируем нажатие левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);; {Имитируем отпускание левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);; end; Вопрос:
Как программно закрыть другое приложение?
Ответ:
Отправьте этому приложению сообщение WM_QUIT
Пример:
PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0); Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение. Вопрос:
Форматирование диска в Win32
Ответ:
ShellAPI функция ShFormatDrive().
Пример:
const SHFMT_DRV_A = 0; const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end; Вопрос:
Как спрятать и отключить кнопку "Пуск"?
Ответ:
Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает ее.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var Rgn : hRgn; begin {Cпрятать кнопку "Пуск"} 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 Вопрос:
Как временно отключить перерисовку окна?
Ответ:
Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо не обновлять. Передайте ноль в качестве параметра для восстановления нормального обновления. LockWindowUpdate(Memo1.Handle); . . LockWindowUpdate(0); Вопрос:
Моя программа использует дравер принтера. Возможно ли потихоньку установить драйвер принтера без вмешательства пользователя?
Ответ:
Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini. Примечание: DriverName = Имя драйвера; DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).
Пример:
procedure TForm1.Button1Click(Sender: TObject); var s : array[0..64] of char; begin WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45'); WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:'); StrCopy(S, 'PrinterPorts'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); StrCopy(S, 'Devices'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); end; Вопрос:
Как набрать номер с помощью модема в Win32?
Ответ:
Используйте функцию Windows API CreateFile() чтобы получить дескриптор порта, и стандартные функции ввода-вывода для связи с полученным портом.
Пример:
var hCommFile : THandle; procedure TForm1.Button1Click(Sender: TObject); var PhoneNumber : string; CommPort : string; NumberWritten : LongInt; begin PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile=INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Dial the phone} NumberWritten:=0; if WriteFile(hCommFile, PChar(PhoneNumber)^, Length(PhoneNumber), NumberWritten, nil) = false then begin ShowMessage('Unable to write to ' + CommPort); end; end; procedure TForm1.Button2Click(Sender: TObject); begin {Close the port} CloseHandle(hCommFile); end; Вопрос:
Как использовать TAPI для голосового звонка?
Ответ:
См пример.
Пример:
{tapi Errors} const TAPIERR_CONNECTED = 0; const TAPIERR_DROPPED = -1; const TAPIERR_NOREQUESTRECIPIENT = -2; const TAPIERR_REQUESTQUEUEFULL = -3; const TAPIERR_INVALDESTADDRESS = -4; const TAPIERR_INVALWINDOWHANDLE = -5; const TAPIERR_INVALDEVICECLASS = -6; const TAPIERR_INVALDEVICEID = -7; const TAPIERR_DEVICECLASSUNAVAIL = -8; const TAPIERR_DEVICEIDUNAVAIL = -9; const TAPIERR_DEVICEINUSE = -10; const TAPIERR_DESTBUSY = -11; const TAPIERR_DESTNOANSWER = -12; const TAPIERR_DESTUNAVAIL = -13; const TAPIERR_UNKNOWNWINHANDLE = -14; const TAPIERR_UNKNOWNREQUESTID = -15; const TAPIERR_REQUESTFAILED = -16; const TAPIERR_REQUESTCANCELLED = -17; const TAPIERR_INVALPOINTER = -18; {tapi size constants} const TAPIMAXDESTADDRESSSIZE = 80; const TAPIMAXAPPNAMESIZE = 40; const TAPIMAXCALLEDPARTYSIZE = 40; const TAPIMAXCOMMENTSIZE = 80; const TAPIMAXDEVICECLASSSIZE = 40; const TAPIMAXDEVICEIDSIZE = 40; function tapiRequestMakeCallA(DestAddress : PAnsiChar; AppName : PAnsiChar; CalledParty : PAnsiChar; Comment : PAnsiChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCallW(DestAddress : PWideChar; AppName : PWideChar; CalledParty : PWideChar; Comment : PWideChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCall(DestAddress : PChar; AppName : PChar; CalledParty : PChar; Comment : PChar) : LongInt; stdcall; external 'TAPI32.DLL'; procedure TForm1.Button1Click(Sender: TObject); var DestAddress : string; CalledParty : string; Comment : string; begin DestAddress := '1-555-555-1212'; CalledParty := 'Frank Borland'; Comment := 'Calling Frank'; tapiRequestMakeCall(pChar(DestAddress), PChar(Application.Title), pChar(CalledParty), PChar(Comment)); end; end. Вопрос:
Как показать иконку, ассоциированной с данным типом файла?
Ответ:
ShellApi функция ExtractAssociatedIcon()
Пример:
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; Вопрос:
Как определение нажатия определенной клавиши во время загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для определения нажатия клавиши в тексте проекта. Для того чтобы увидеть текст файла проекта в главном меню Delphi 3 выберите "View">>"ProjectSource" в Delphi 4 "Project">>"View Source".
Пример:
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. Вопрос:
Как заставить пикнуть динамик несколько раз с небольшой задержкой между сигналами, не зависящей от тактовой частоты процессора?
Ответ:
См. пример.
Пример:
procedure Delay(ms : longint); {$IFNDEF WIN32} var TheTime : LongInt; {$ENDIF} begin {$IFDEF WIN32} Sleep(ms); {$ELSE} TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); end; Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия и пункт "закрыть" ситсемного меню заданного окна. procedure TForm1.Button1Click(Sender: TObject); var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Untitled - Notepad'); if (hwndHandle <> 0) then begin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end; Вопрос:
Как узнать путь к каталогам Windows?
Ответ:
Следующий пример получает полный список каталогов по умолчанию (Favorites, Desktop, Programs, Fonts, SendTo, Start, Menu, Templates, Startup, Recent and NetHood) Windows и заносит его в Memo.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_CURRENT_USER; reg.LazyWrite := false; reg.OpenKey( 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end; Вопрос:
Как узнать полный путь и имя файла загруженной DLL?
Ответ:
См. пример
Пример:
uses Windows; procedure ShowDllPath stdcall; var TheFileName : array[0..MAX_PATH] of char; begin FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); end; Вопрос:
Как вызвать диалог 'Найти файлы и паки' проводника?
Ответ:
Приведенный пример показывает использование DDE для вызова диалога 'Найти файлы и паки' Explorerа. Диалог открывается на каталоге "C:\Download". 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; Вопрос:
Как сделать родительское окно с фоновым рисунком в клиентской области?
Ответ:
Для того чтобы сделать это выполните следующие шаги: Срздайте новый проект. Установите FormStyle формы в fsMDIForm Разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: FClientInstance : TFarProc; FPrevClientProc : TFarProc; procedure ClientWndProc(var Message: TMessage); Добаьте следующие строки в разделе implementation: procedure TMainForm.ClientWndProc(var Message: TMessage); var Dc : hDC; Row : Integer; Col : Integer; begin with Message do case Msg of WM_ERASEBKGND: begin Dc := TWMEraseBkGnd(Message).Dc; for Row := 0 to ClientHeight div Image1.Picture.Height do for Col := 0 to ClientWidth div Image1.Picture.Width do BitBlt(Dc, Col * Image1.Picture.Width, Row * Image1.Picture.Height, Image1.Picture.Width, Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY); Result := 1; end; else Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam); end; end; В методе формы OnCreate добавьте: FClientInstance := MakeObjectInstance(ClientWndProc); FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)); SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance)); Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild. У Вас получился MDI-проект с "обоями" в клиентской области MDI формы. Вопрос:
Как глобально перехватить нажатие кнопки PrintScreen?
Ответ:
В примере для глобального перехвата нажатия клавиши printscreen регистрируется горячая клавиша (hot key).
Пример:
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; Вопрос:
Существует ли способ для определение числа заданий spoolerа печати?
Ответ:
Spoolerа печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение
Пример:
type TForm1 = class(TForm) Label1: TLabel; private { Private declarations } procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); begin Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; msg.Result := 0; end; Вопрос:
Как определить имена установленых Com-портов?
Ответ:
Из реестра. См. пример.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('hardware\devicemap\serialcomm', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end; Вопрос:
Извлечение пиктограммы из exe, dll или ico-файла
Ответ:
Функция SHELLAPI ExtractIconEx:
Обратите внимание - в примере функции обьявленны иначе, чем в модуле ShellAPI type ThIconArray = array[0..0] of hIcon; type PhIconArray = ^ThIconArray; function ExtractIconExA(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; function ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; phiconLarge: PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExW'; function ExtractIconEx(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; procedure TForm1.Button1Click(Sender: TObject); var NumIcons : integer; pTheLargeIcons : phIconArray; pTheSmallIcons : phIconArray; LargeIconWidth : integer; SmallIconWidth : integer; SmallIconHeight : integer; i : integer; TheIcon : TIcon; TheBitmap : TBitmap; begin NumIcons := ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', -1, nil, nil, 0); if NumIcons > 0 then begin LargeIconWidth := GetSystemMetrics(SM_CXICON); SmallIconWidth := GetSystemMetrics(SM_CXSMICON); SmallIconHeight := GetSystemMetrics(SM_CYSMICON); GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 0, pTheLargeIcons, pTheSmallIcons, numIcons); {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} for i := 0 to (NumIcons - 1) do begin DrawIcon(Form1.Canvas.Handle, i * LargeIconWidth, 0, pTheLargeIcons^[i]); TheIcon := TIcon. Create; TheBitmap := TBitmap.Create; TheIcon.Handle := pTheSmallIcons^[i]; TheBitmap.Width := TheIcon.Width; TheBitmap.Height := TheIcon.Height; TheBitmap.Canvas.Draw(0, 0, TheIcon); TheIcon.Free; Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap); TheBitmap.Free; end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); end; end; end. Вопрос:
как заставить Рабочий Стола Windows обновится?
Ответ:
См. пример.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); end; Вопрос:
Перерисовка canvasf моей формы занимает довольно много времени. Как определить установлен ли у пользователя режим перерисовки всего окна при перемещении чтобы временно отключить перерисовку моего окна?
Ответ:
В приведенном примере определяется включен ли режим "Full Window Drag" (перерисовки всего окна при перемещении)
Пример:
procedure TForm1.Button1Click(Sender: TObject); var b : bool; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); if not b then ShowMessage('Full Window Drag is not enabled') else ShowMessage('Full Window Drag is enabled'); end; Вопрос:
Как уступить выделенный моей программе квант процессорного времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep() передав ноль в качестве параметра.
Вопрос:
Как запускать мою программу на каждом старте Windows?
Ответ:
Пример работает и для Win32и для Win16. uses Registry, {For Win32} IniFiles; {For Win16} {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} {For Win32} procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false); reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free; end; {For Win16} procedure TForm1.Button2Click(Sender: TObject); var WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string; begin GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); s := WinIni.ReadString('windows', 'run', ''); if s = '' then s := Application.ExeName else s := s + ';' + Application.ExeName; WinIni.WriteString('windows', 'run', s); WinIni.Free; end; Вопрос:
Как увеличить процессорное время, выделяемого программе?
Ответ:
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привети к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; begin ProcessID := GetCurrentProcessID; ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID); SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); ThreadHandle := GetCurrentThread; SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); end; Вопрос:
Я хочу определить момент окончания изменения размера или перемещения окна. Перехватываю сообщения WM_SIZE и WM_MOVE но я получаю много таких сообщений а мне нужно узнать когда именно пользователь закончил перенос или изменение размеров окна. Возможно ли это?
Ответ:
В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна.
Пример:
type TForm1 = class(TForm) private { Private declarations } public procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage); begin Form1.Caption := 'Finished Moving and sizing'; end; Вопрос:
Как определить время последнего доступа к файлу?
Ответ:
См пример. Примечание: не все файловые системы поддерживают время последнего доступа к файлу.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime; begin Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec); if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then begin FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); FileTimeToSystemTime(DT,ST); Memo1.Lines.Clear; Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); end; SysUtils.FindClose(SearchRec); end; Вопрос:
Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?
Ответ:
См. пример
Пример:
uses ShellAPI, ShlObj; procedure TForm1.Button1Click(Sender: TObject); var TitleName : string; lpItemID : PItemIDList; BrowseInfo : TBrowseInfo; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; begin FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle; BrowseInfo.pszDisplayName := @DisplayName; TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); end; end; Вопрос:
Как получить дескриптора окна Window, сожержащего DOS программу или программу консольного режима?
Ответ:
В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var info : TOSVersionInfo; ClassName : string; Title : string; begin {Проверяем - Win95 или NT.} info.dwOSVersionInfoSize := sizeof(info); GetVersionEx(info); if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin ClassName := 'ConsoleWindowClass'; Title := 'Command Prompt'; end else begin ClassName := 'tty'; Title := 'MS-DOS Prompt'; end; ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); end; Вопрос:
Возможно ли определить факта изменения системного времени другим приложением?
Ответ:
Следующий прмер перехватывает событие WM_TIMECHANGE. примечание: Приложение , изменяющее системное время должно посылать сообщение WM_TIMECHANGE всем окнам. type TForm1 = class(TForm) private { Private declarations } procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); begin Form1.Caption := 'Time Changed'; end; Вопрос:
Как очистить пункт документы меню кнопки Пуск
Ответ:
Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); begin SHAddToRecentDocs(SHARD_PATH, nil); end; Вопрос:
Как опеределить состояние модема под Win32?
Ответ:
См. пример
Пример:
procedure TForm1.Button1Click(Sender: TObject); var CommPort : string; hCommFile : THandle; ModemStat : DWord; begin CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile = INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Get the Modem Status} if GetCommModemStatus(hCommFile, ModemStat) <> false then begin if ModemStat and MS_CTS_ON <> 0 then ShowMessage('The CTS (clear-to-send) is on.'); if ModemStat and MS_DSR_ON <> 0 then ShowMessage('The DSR (data-set-ready) is on.'); if ModemStat and MS_RING_ON <> 0then ShowMessage('The ring indicator is on.'); if ModemStat and MS_RLSD_ON <> 0 then ShowMessage('The RLSD (receive-line-signal-detect) is on.'); end; {Close the comm port} CloseHandle(hCommFile); end; Вопрос:
Как добавить пункт к системному меню приложения?
Пример:
type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const SC_MyMenuItem = WM_USER + 1; procedure TForm1.FormCreate(Sender: TObject); begin AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, ''); AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'My Menu Item'); end; procedure TForm1.WMSysCommand(var Msg: TWMSysCommand); begin if Msg.CmdType = SC_MyMenuItem then ShowMessage('Got the message') else inherited; end; Вопрос:
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?
Ответ:
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC. var OriginalWordBreakProc : pointer; NewWordBreakProc : pointer; function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer; code : integer) : integer {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin result := 0; end; procedure TForm1.FormCreate(Sender: TObject); begin OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle, EM_GETWORDBREAKPROC, 0, 0)); {$IFDEF WIN32} NewWordBreakProc := @MyWordBreakProc; {$ELSE} NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance); {$ENDIF} SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(NewWordBreakProc)); end; procedure TForm1.FormDestroy(Sender: TObject); begin SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(@OriginalWordBreakProc)); {$IFNDEF WIN32} FreeProcInstance(NewWordBreakProc); {$ENDIF} end; Вопрос:
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который использует "Проводник" (Explorer)?
Ответ:
В следующем примере используется функция SHFileOperation для копирования группы файлов и показа анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и переименования файлов. TO_COPY FO_DELETE FO_MOVE FO_RENAME Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми символами.
Пример:
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); var Fo : TSHFileOpStruct; buffer : array[0..4096] of char; p : pchar; begin FillChar(Buffer, sizeof(Buffer), #0); p := @buffer; p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1; StrECopy(p, 'C:\DownLoad\4.ZIP'); FillChar(Fo, sizeof(Fo), #0); Fo.Wnd := Handle; Fo.wFunc := FO_COPY; Fo.pFrom := @Buffer; Fo.pTo := 'D:\'; Fo.fFlags := 0; if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then ShowMessage('Cancelled') end; Вопрос:
Как узнать серийный номер диска
Ответ:
procedure TForm1.Button1Click(Sender: TObject); var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; begin GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); end; Вопрос:
Как узнать является диск CD-диском,сетевым диском, виртуальным диском или сьемным диском?
Ответ:
Windows API функция GetDriveType().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined'); 1 : ShowMessage('The root directory does not exist'); DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); DRIVE_FIXED : ShowMessage('The disk cannot be removed'); DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive'); DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive'); DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk'); end; end; Вопрос:
Как проверить готовность диска без появления окна ошибки Windows?
Ответ:
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Пример:
function IsDriveReady(DriveLetter : char) : bool; var OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+} if IoResult <> 0 then Result := False else Result := True; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; procedure TForm1.Button1Click(Sender: TObject); begin if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready'); end; Вопрос:
Использование FindFirst для поиска файлов.
Ответ:
begin Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end; Вопрос:
Как получить дескриптор окна другого приложения и сделать его активным?
Ответ:
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Вам нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью совпадающее название оконного класса (если он задан) и делает это окно активным. type PFindWindowStruct = ^TFindWindowStruct; TFindWindowStruct = record Caption : string; ClassName : string; WindowHandle : THandle; end; function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var lpBuffer : PChar; WindowCaptionFound : bool; ClassNameFound : bool; begin GetMem(lpBuffer, 255); Result := True; WindowCaptionFound := False; ClassNameFound := False; try if GetWindowText(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true; if PFindWindowStruct(lParam).ClassName = '' then ClassNameFound := True else if GetClassName(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True; if (WindowCaptionFound and ClassNameFound) then begin PFindWindowStruct(lParam).WindowHandle := hWindow; Result := False; end; finally FreeMem(lpBuffer, sizeof(lpBuffer^)); end; end; function FindAWindow(Caption : string; ClassName : string) : THandle; var WindowInfo : TFindWindowStruct; begin with WindowInfo do begin Caption := Caption; ClassName := ClassName; WindowHandle := 0; EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); FindAWindow := WindowHandle; end; end; procedure TForm1.Button1Click(Sender: TObject); var TheWindowHandle : THandle; begin TheWindowHandle := FindAWindow('Netscape - ', ''); if TheWindowHandle = 0 then ShowMessage('Window Not Found!') else BringWindowToTop(TheWindowHandle); end; Вопрос:
Как написать программу не имеющую ни одной формы?
Ответ:
Создайте новое приложение, затем удалите из проекта все unitы - (Delphi 3 - View - Project Manager)
(Delphi 4 - Project - Remove from project)
Откройте файл проекта
(Delphi 3 - View - Project Source)
(Delphi 3 - Project - View Source)
и отредактируйте его так как приведино ниже.
Пример:
program Project1; {$R *.RES} uses SysUtils; var f : TextFile; begin AssignFile(f, 'TestFile.Txt'); ReWrite(f); Writeln(f, 'Test'); Close(f); end. Вопрос:
Почему возникает ошибка при передаче параметров типа boolean равного True в некоторые внешней функции
Ответ:
В Delphi 3 значение "True" для типов ByteBool, WordBool LongBool представляется как -1 для совместимости с Microsoft Visual Basic. Многие компиляторы представляют "True" как либо "не нуль" либо 1. При передаче параметров в не Visual Basic-приложения Вам следует придерживаться следующей техники во избежание несовместимости: LongBool(Abs(True)); При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем. if BoolValPassed <> False then DoSomething. Вопрос:
Как получить длинное имя файла или каталога, зная короткое имя?
Ответ:
Используйте Win32_Find_Data поле TSearchRec.
Пример:
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; Вопрос:
Как временно отключить range checking для участка программы, а затем вновь вклчить его?
Ответ:
Можно сделать это, используя "IFOPT" и "DEFINE". type PSomeArray = ^TSomeArray; TSomeArray = array[0..0] of integer; procedure TForm1.Button1Click(Sender: TObject); var p : PSomeArray; i : integer; begin {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} GetMem(p, sizeof(integer) * 200); try for i := 1 to 200 do p[i] := i; finally FreeMem(p, sizeof(integer) * 200); end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end; Вопрос:
Как получить имя файла и путь локальной таблицы?
Ответ:
Следующий пример взят из файла BDE32.HLP Borland/CommonFiles/BDE directory: implementation {$R *.DFM} uses DbiTypes, DbiProcs; function fDbiFormFullName(Tbl: TTable): String; var Props: CurProps; Buffer1 : array[0..DBIMAXPATHLEN] of char; Buffer2 : array[0..DBIMAXPATHLEN] of char; begin Check(DbiGetCursorProps(Tbl.Handle,Props)); StrPCopy(Buffer1, Tbl.TableName); Check(DbiFormFullName(Tbl.DBHandle, @Buffer1, Props.szTableType, @Buffer2)); Result := StrPas(Buffer2); end; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(fDbiFormFullName(Table1)); end; Примечание: Таблица должна быть открытой. Работает с локальными таблицами. Вопрос:
Как получить дескриптор панели задач (TaskBar)?
Ответ:
hTaskbar := FindWindow('Shell_TrayWnd', Nil ); Вопрос:
Как из программы запустить Screen Saver?
Ответ:
Представленная ниже функция демонстрирует как это сделать function TurnScreenSaverOn : bool; var b : bool; begin result := false; if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then exit; if not b then exit; PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0); result := true; end; Вопрос:
Как выяснить установлены ли в системе шрифты TrueType?
Ответ:
function IsTrueTypeAvailable : bool; var {$IFDEF WIN32} rs : TRasterizerStatus; {$ELSE} rs : TRasterizer_Status; {$ENDIF} begin result := false; if not GetRasterizerCaps(rs, sizeof(rs)) then exit; if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit; if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit; result := true; end; Вопрос:
Как переслать файл в Мусорную Корзину?
Ответ:
Используйте функцию SHFileOperation(). uses ShellAPI; procedure SendToRecycleBin(FileName: string); var SHF: TSHFileOpStruct; begin with SHF do begin Wnd := Application.Handle; wFunc := FO_DELETE; pFrom := PChar(FileName); fFlags := FOF_SILENT or FOF_ALLOWUNDO; end; SHFileOperation(SHF); end; procedure TForm1.Button1Click(Sender: TObject); begin SendToRecycleBin('c:\DownLoad\Test.gif'); end; Вопрос:
Как изменить обои Windows програмно?
Ответ:
Изменить обои можно функцией SystemParametersInfo()Б переслав ей в качестве параметров константу SPI_SETDESKWALLPAPER и имя нового файла обоев.
Пример:
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar('C:\SOMEPATH\SOME.BMP'), SPIF_SENDWININICHANGE); Вопрос:
Как выяснить запущен ли Delphi / C++ Builder?
Ответ:
Используйте функцию FindWindow. (Класс главного окна Delphi / C++ Builder - TAppBuilder) if FindWindow('TAppBuilder', Nil) <> 0 Then ShowMessage('Delphi and or C++ Builder is running'); Вопрос:
Как програмно выяснить версию Windows?
Ответ:
{$IFDEF WIN32} function GetVersionEx(lpOs : pointer) : BOOL; stdcall; external 'kernel32' name 'GetVersionExA'; {$ENDIF} procedure GetWindowsVersion(var Major : integer; var Minor : integer); var {$IFDEF WIN32} lpOS, lpOS2 : POsVersionInfo; {$ELSE} l : longint; {$ENDIF} begin {$IFDEF WIN32} GetMem(lpOS, SizeOf(TOsVersionInfo)); lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo); while getVersionEx(lpOS) = false do begin GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1); lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); lpOS := lpOs2; end; Major := lpOs^.dwMajorVersion; Minor := lpOs^.dwMinorVersion; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); {$ELSE} l := GetVersion; Major := LoByte(LoWord(l)); Minor := HiByte(LoWord(l)); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); var Major : integer; Minor : integer; begin GetWindowsVersion(Major, Minor); Memo1.Lines.Add(IntToStr(Major)); Memo1.Lines.Add(IntToStr(Minor)); end; Вопрос:
Как узнать переменные окружения (environment variable) DOS, например path?
Ответ:
Windows API - функция GetDOSEnvironment() для Win16 и GetEnvironmentStrings() для Win32.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var p : pChar; begin Memo1.Lines.Clear; Memo1.WordWrap := false; {$IFDEF WIN32} p := GetEnvironmentStrings; {$ELSE} p := GetDOSEnvironment; {$ENDIF} while p^ <> #0 do begin Memo1.Lines.Add(StrPas(p)); inc(p, lStrLen(p) + 1); end; {$IFDEF WIN32} FreeEnvironmentStrings(p); {$ENDIF} end; Вопрос:
Как рисовать непосредственно на Рабочем столе?
Ответ:
Пример:
procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end; Вопрос:
Как определить каталог Windows?
Ответ:
Вызовите функцию GetWindowsDirectory(). Если Вас интересует каталог System, вызовите функцию GetSystemDirectory().
Пример:
{$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var a : Array[0..MAX_PATH] of char; begin GetWindowsDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); GetSystemDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); end; Вопрос:
Как определить размер рабочего стола без Тaskbar'а?
Ответ:
Воспользуйтесь функцией SystemParametersInfo(), переслав ей в качестве параметров - SPI_GETWORKAREA и адрес структуры типа TRect, куда будут передан полученный результат.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var r : TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0); Memo1.Lines.Add(IntToStr(r.Top)); Memo1.Lines.Add(IntToStr(r.Left)); Memo1.Lines.Add(IntToStr(r.Bottom)); Memo1.Lines.Add(IntToStr(r.Right)); end; Вопрос:
Как закрыть CD програмно?
Ответ:
Вызовите функцию mciSendCommand (из библиотекиMMSystem) передав ей параметр MCI_SET_DOOR_CLOSED.
Пример:
uses MMSystem; procedure CloseCD(Drive : char); var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Open; Application.ProcessMessages; mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0); Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin CloseCD('D'); end; Вопрос:
Как определить свободное дисковое пространство на дисках размером больше 2 ГБ?
Ответ:
Вызовите функцию GetDiskFreeSpaceEx(). Возвращаемый функцией результат типа integers конвертируйте в doubles.
Пример:
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer; var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall; external kernel32 name 'GetDiskFreeSpaceExA'; procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double); var AvailToCall : integer; TheSize : integer; FreeAvail : integer; begin GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail); {$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF} if TheSize >= 0 then TotalBytes := TheSize else if TheSize = -1 then begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1; end else begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize); end; if AvailToCall >= 0 then TotalFree := AvailToCall else if AvailToCall = -1 then begin TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1; end else begin TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall); end; end; procedure TForm1.Button1Click(Sender: TObject); var TotalBytes : double; TotalFree : double; begin GetDiskSizeAvail('C:\', TotalBytes, TotalFree); ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree)); end; Вопрос:
Как спрятать Панель Задач Windows (Task Bar)?
Ответ:
Вначале необходимо вызвать функцию FindWindow(), чтобы определить handle TaskBar. Затем вызвите функцию ShowWindow(), передав ей в качестве параметра костанту SW_HIDE.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE); end; procedure TForm1.Button2Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL); end; Вопрос:
Как определить подключен ли компюетер к сети.
Ответ:
Воспользуйтесь функцией GetSystemMetrics(), переслав ей флаг SM_NETWORK.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network'); end; Вопрос:
Как добавить документ в меню ПУСК - ДОКУМЕНТЫ?
Ответ:
Используйте функцию SHAddToRecentDocs.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); var s : string; begin s := 'C:\DownLoad\ntkfaq.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); end; Вопрос:
Как программно изменить текущий порт принтера?
Ответ:
Используйте метод SetPrinter класса TPrinter.
Пример:
uses Printers; {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var pDevice : pChar; pDriver : pChar; pPort : pChar; hDMode : THandle; PDMode : PDEVMODE; begin if PrintDialog1.Execute then begin GetMem(pDevice, cchDeviceName); GetMem(pDriver, MAX_PATH); GetMem(pPort, MAX_PATH); Printer.GetPrinter(pDevice, pDriver, pPort, hDMode); Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode); FreeMem(pDevice, cchDeviceName); FreeMem(pDriver, MAX_PATH); FreeMem(pPort, MAX_PATH); Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!'); Printer.EndDoc; end; end; Вопрос:
Как корректно определить изменения в оборудовании PlugNPlay?
Ответ:
Пример:
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; Вопрос:
Как после записи в ini-файл сбросить cache на диск, чтоб задействовать изменения?
Ответ:
Вызовите функцию WriteProfileString() или WritePrivateProfileString(), передав ей в качестве параметров секции, ключа и строки - nil.
Пример:
WriteProfileString(nil, nil, nil); WritePrivateProfileString(nil, nil, nil, FileName); Вопрос:
Как с помощью Проводника открыть конкретный каталог?
Ответ:
Пример:
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); end; Вопрос:
Как запустить аплет Панели управления?
Ответ:
Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения файла control.exe, которому передано имя аплета. Обычно аплеты панели управления расположены в каталоге System Windows и имеют расширение .cpl.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal); end; Вопрос:
Как печатать в цвете?
Ответ:
Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен в этот режим. Windows автоматически переведет цветную печать в черно-белую, если принтер не поддерживает цветной печати. Если Вам необходимо програмно изменить режим цвета, Вы можете обратится к структуре DevMode драйвера принтера.
Пример:
uses Printers; procedure TForm1.Button1Click(Sender: TObject); var Device : array[0..255] of char; Driver : array[0..255] of char; Port : array[0..255] of char; hDMode : THandle; PDMode : PDEVMODE; begin with Printer do begin PrinterIndex := PrinterIndex; GetPrinter(Device, Driver, Port, hDMode); if hDMode <> 0 then begin pDMode := GlobalLock(hDMode); if pDMode <> nil then begin pDMode.dmFields := pDMode.dmFields or dm_Color; pDMode.dmColor := DMCOLOR_COLOR; GlobalUnlock(hDMode); end; end; PrinterIndex := PrinterIndex; BeginDoc; Canvas.Font.Color := clRed; Canvas.TextOut(100,100, 'Red As A Rose!'); EndDoc; end; end; Вопрос:
Как открыть URL браузером, установленным по умолчанию?
Ответ:
Используйте функцию ShellExecute.
Пример:
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Form1.Handle, nil, 'http://www.borland.com', nil, nil, SW_SHOWNORMAL); end; Вопрос:
Как стереть ехе-файл во время его исполнения?
Ответ:
Это не возможно. Вы можете стереть его во время следующего запуска Windows, добавив ключ RunOnce: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; with reg do begin RootKey := HKEY_LOCAL_MACHINE; LazyWrite := false; OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false); WriteString('Delete Me!','command.com /c del FILENAME.EXT'); CloseKey; free; end; end; Вопрос:
Как програмноинсталировать шрифты TrueType?
Ответ:
Скопируйте файл шрифта в директорию Windows\Fonts, и добавьте строку с именем шрифта и его расположением в разделе "'Software\Microsoft\Windows\CurrentVersion\Fonts". Вызовите функцию AddFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE. И наконец, для удоления установленного шрифта, вызовите функцию RemoveFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; b : bool; begin CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b); reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false); reg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); reg.CloseKey; reg.free; {Add the font resource} AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); {Remove the resource lock} RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; Вопрос:
Как получить список часовых поясов?
Ответ:
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false); if reg.HasSubKeys then begin ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey; for i := 0 to ts.Count -1 do begin reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false); Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display')); Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt')); Memo1.Lines.Add('----------------------'); reg.CloseKey; end; ts.Free; end else reg.CloseKey; reg.free; end; Вопрос:
Какие значения возвращает функция GetTimeZoneInformation()?
Ответ:
const TIME_ZONE_ID_UNKNOWN = 0; const TIME_ZONE_ID_STANDARD = 1; const TIME_ZONE_ID_DAYLIGHT = 2; Вопрос:
Как сделать прозрачным фон текста?
Ответ:
Используйте функцию SetBkMode().
Пример:
procedure TForm1.Button1Click(Sender: TObject); var OldBkMode : integer; begin with Form1.Canvas do begin Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); end; end; Вопрос:
Как получить информацию о версии файла?
Ответ:
Для этого необходимо вызвать несколько функций API. В приведеннном ниже примере проверяется версия shell32.dll. Функция возвращает значение True - если версия DLL больше или равна 4.71 function TForm1.CheckShell32Version: Boolean; procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); { Helper function to get the actual file version information } var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; begin // Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); // If InfoSize = 0, then the file may not exist, or // it may not have file version information in it. if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName); // Allocate memory for the file version information GetMem(Info, InfoSize); try // Get the information GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; finally FreeMem(Info, FileInfoSize); end; end; var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer; VersionMinor: Integer; Blank: Integer; begin tmpBuffer := AllocMem(MAX_PATH); // Get the shell32.dll path try GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll'; finally FreeMem(tmpBuffer); end; // Check to see if it exists if FileExists(Shell32Path) then begin // Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank); // Do something, such as require a certain version // (such as greater than 4.71) if (VersionMajor >= 4) and (VersionMinor >= 71) then Result := True else Result := False; end else Result := False; end; Вопрос:
Как создать иконку из bitmap'а?
Ответ:
Нужно создать два bitmap'а: bitmap-маску ("AND" bitmap) и bitmap-картинку (XOR bitmap). Потом передать дескрипторы "AND" и "XOR" bitmap-ов API функции CreateIconIndirect()
Пример:
procedure TForm1.Button1Click(Sender: TObject); var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; begin {Get the icon size} IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {Create the "And" mask} AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {Draw on the "And" mask} AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Create the "XOr" mask} XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Draw on the "XOr" mask} XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Create a icon} Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Destroy the temporary bitmaps} AndMask.Free; XOrMask.Free; {Draw as a test} Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Assign the application icon} Application.Icon := Icon; {Force a repaint} InvalidateRect(Application.Handle, nil, true); {Free the icon} Icon.Free; end; Вопрос:
Как преобразовать RGB-цвет в оттенки серого?
Ответ:
В приведенном примере для преобразования RGB-цвета используются коэффициенты, принятые в телевидении: function RgbToGray(RGBColor : TColor) : TColor; var Gray : byte; begin Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor ))); Result := RGB(Gray, Gray, Gray); end; procedure TForm1.FormCreate(Sender: TObject); begin Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); end; Вопрос:
Как держать приложение в минимизированном виде?
Ответ:
Установите свойство WindowState в Minimized. Создайте обработчик сообщения WM_QueryOpen.
Пример:
{Place this code in the private section of the Form declaration} procedure WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN; {Place this code in the Form implementation section} procedure TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen); begin Msg.Result := 0; end; Вопрос:
при вызове функции RegisterClass я получаю ошибку: "Incompatible types: 'TPersistantClass' and 'TWndClassA'"
Ответ:
Функция RegisterClass() обьявлена в модулях Classes и Windows unit. Чтобы вызвать функцию из модуля Windows просто добавте префикс "Windows."
Пример:
procedure TForm1.Button1Click(Sender: TObject); wc : TWndClass; begin Windows.RegisterClass(wc) end; Вопрос:
Как принять файлы, брошенные на мою форму по drag & drop
Ответ:
Нужно сообщить Windows, что ваша форма принимает файлы по drag & drop с помощью функции Shell API DragAcceptFiles.(в обработчике события form create) Затем нужно реагироавть на сообытия drag & drop чтобы принять файлы. (см. пример) unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); private procedure WMDROPFILES(var Message: TWMDROPFILES); message WM_DROPFILES; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellApi; procedure TForm1.FormCreate(Sender: TObject); begin {Let Windows know we accept dropped files} DragAcceptFiles(Form1.Handle, True); end; procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES); var NumFiles : longint; i : longint; buffer : array[0..255] of char; begin {How many files are being dropped} NumFiles := DragQueryFile(Message.Drop, -1, nil, 0); {Accept the dropped files} for i := 0 to (NumFiles - 1) do begin DragQueryFile(Message.Drop, i, @buffer, sizeof(buffer)); Form1.Memo1.Lines.Add(buffer); end; end; end. Вопрос:
Как создать задержку не подвешивая систему без компонента TTimer ?
Ответ:
В примере используется вызов Application.ProcessMessages для того, чтобы Windows обрабатывал сообщения во время цикла задержки. procedure Delay(ms : longint); var TheTime : LongInt; begin TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Start Test'); Delay(2000); ShowMessage('End Test'); end; Вопрос:
Как програмно перезагрузить Windows? Ответ: Используйте функцию ExitWindows(). В качестве первого параметра ей передается она из трех констант: EW_RESTARTWINDOWS EW_REBOOTSYSTEM EW_EXITANDEXECAPP Второй параметр используется для перезагрузки компьютера в режиме эмуляции MS DOS.
Пример:
ExitWindows(EW_RESTARTWINDOWS, 0 );
(c) 1999 .
Last Modified Friday, 06-Aug-99 11:12:04 PST.
Translated & Adapted by
17-Aug-1999
Заготовки для сборщика мусора.
Для использования мониторинга, модуль GCSystem.pas нужно включить первым в проект.
В каталоге программы создастся файл log.txt, в котором будут все выделения и освобождения памяти, а также создание/уничтожение объектов.
Файл log.txt можно обработать анализатором (analog.bat). При этом создадутся файлы log1.txt с неосвобождённой памятью и log2.txt с неудалёнными объектами.
GCSystem.pas работает как при сборке с пакетами, так и без.
Примеры логов:
Log1.txt:
| +16, Address: 13241272 +16, Address: 13244248 ReallocMem, +32 Address Source: 13244248 Address Dest: 13244248 +16, Address: 13244644 +16, Address: 13244664 ReallocMem, +48 Address Source: 13244248 Address Dest: 13244732 +16, Address: 13244840 +16, Address: 13244876 +16, Address: 13244912 +16, Address: 13244952 +16, Address: 13244996 +128, Address: 13245016 ReallocMem, +32 Address Source: 13244664 Address Dest: 13246016 ReallocMem, +48 Address Source: 13246016 Address Dest: 13246080 +16, Address: 13244664 ReallocMem, +112 Address Source: 13246080 Address Dest: 13262008 |
Log2.txt:
| +16, Address: 13241252 Create: TIntConst, Address: 13241252 +16, Address: 13241292 Create: TIntConst, Address: 13241292 +48, Address: 13242948 Create: THelpManager, Address: 13242948 +20, Address: 13243000 Create: TObjectList, Address: 13243000 +20, Address: 13243024 Create: TObjectList, Address: 13243024 +20, Address: 13243048 Create: TObjectList, Address: 13243048 +16, Address: 13244112 Create: TIntConst, Address: 13244112 +20, Address: 13244132 Create: TRegGroup, Address: 13244132 +16, Address: 13244156 Create: TList, Address: 13244156 +48, Address: 13244176 Create: TStringList, Address: 13244176 +16, Address: 13244228 Create: TList, Address: 13244228 +36, Address: 13244784 Create: TWinHelpViewer, Address: 13244784 +16, Address: 13244932 Create: TList, Address: 13244932 +28, Address: 13260600 Create: TCriticalSection, Address: 13260600 |
Скачать:
"Живой Desktop" — вариант использования Shell
| Раздел Сокровищница |
Что это:Прикольное расширение Shellа. Назначение:Разовое применение с целью разрушить устоявшееся представление индивидума о незыблемости иконок на рабочем столе. Показания:
Внимание - это демонстрация, содержит как минимум одну ошибку приводящую к завершению работы Explorerа без сохранения данных через ~ 20 мин.
Предыстория: Работает у нас один парень все ничего вот только у него странная тяга к иконкам на рабочем столе что выражается в их не мерянном количестве и особо структурированном распределении (сложном и непонятном с полпинка). Как то раз, с утречка он включает комп и... О БОЖЕ !?!?!, по неизвестной причине, ОНИ (иконки - прядка 30~40 штук) были упорядочены!!! и выровнены!!! стандартным образом... что тут началось... (вырезано по требованию правозащитных организаций ) прям конец света :) в общем стены устояли. Парень наотрез отказался работать до тех пор пока не расставит все иконки в только ему ведомом порядке и в соответствии с распределением космических сил - ушел в нирвану на пол дня.
Ну и я, под впечатлением от силы воздействия иконок, решил написать прогу по их своеобразному упрядовачиванию в (как говорится) real-time :) Как сделано: После взвешивания цели и возможных средств доставки было выбрано - повесить на получение контекстного меню (Explorer файл/папка) дллку в которой собственно и осуществляется вся работа.
В качестве основы был взят пример \Borland\Delphi6\Demos\ActiveX\ShellExt\..
Реализовано три алгоритма поведения иконок - черви (Worms), частицы (Atoms) и мышь серая (Mouse).
Митронов Станислав
Программирование: Языки - Технологии - Разработка
- Программирование
- Технологии программирования
- Разработка программ
- Работа с данными
- Методы программирования
- IDE интерфейс
- Графический интерфейс
- Программирование интерфейсов
- Отладка программ
- Тестирование программ
- Программирование на Delphi
- Программирование в ActionScript
- Assembler
- Basic
- Pascal
- Perl
- VBA
- VRML
- XML
- Ada
- Lisp
- Python
- UML
- Форт
- Языки программирования