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

Архитектура x86.

Архитектура x86.

Введение

Код и данные: основной принцип работы процессора

Итак, если не пытаться изложить здесь «кратенько» курс информатики для средней школы, то единственное что хотелось бы напомнить — это то, что процессор (за редкими исключениями) исполняет не программы, написанные на каком-нибудь языке программирования (один из которых, вы, возможно, даже знаете), а некий «машинный код». То есть командами для него являются последовательности байтов, находящихся в памяти компьютера. Иногда команда может быть равна одному байту, иногда она занимает несколько байт. Там же, в основной памяти (ОЗУ, RAM) находятся и данные. Они могут находиться в отдельной области, а могут и быть «перемешаны» с кодом. Различие между кодом и данными состоит в том, что данные — это то, над чем процессор производит какие-то операции. А код — это команды, которые ему сообщают, какую именно операцию он должен произвести. Для упрощения, мы можем представить себе программу и ее данные в виде последовательности байтов некой конечной длины, располагающуюся непрерывно (не будем усложнять) в общем массиве памяти. Например, у нас есть массив памяти длиной в 1’000’000 байт, а наша программа (вместе с данными) — это байты с номерами от 1000 до 20’000. Прочие байты — это другие программы или их данные, или просто свободная память, не занятая ничем полезным.

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

Общие принципы взаимодействия процессора и ОЗУ

Возможно, кого-то удивит, что достаточно большой раздел в FAQ, посвященном x86 CPU, выделен под объяснение особенностей функционирования памяти в современных системах, основанных на данном типе процессоров. Однако факты — упрямая вещь: сами x86-процессоры ныне содержат так много блоков, отвечающих именно за оптимизацию их работы с ОЗУ, что игнорировать эту тесную связь было бы совершенно нелепо. Можно сказать даже так: уж, коль решения, связанные с оптимизацией работы с памятью, стали неотъемлемой частью самих процессоров — то и саму память можно рассматривать в качестве некоего «придатка», функционирование которого оказывает непосредственное влияние на скорость работы CPU. Без понимания особенностей взаимодействия процессора с памятью, невозможно понять, за счёт чего тот или иной процессор (та или иная система) исполняет программы медленнее или быстрее.

Контроллер памяти

Итак, ранее выше мы уже говорили о том, что как команды, так и данные, попадают в процессор из оперативной памяти. На самом деле всё немного сложнее. В большинстве современных x86-систем (то есть компьютеров на базе x86-процессоров), процессор как устройство к памяти обращаться вообще не может, так как не имеет в своем составе соответствующих узлов. Поэтому он обращается к «промежуточному» специализированному устройству, называемому контроллером памяти, а уже тот, в свою очередь — к микросхемам ОЗУ, размещенным на модулях памяти. Модули вы наверняка видели — это такие длинные узкие текстолитовые «планочки» (фактически — небольшие платы) с некоторым количеством микросхем на них, вставляемые в специальные разъемы на системной плате. Роль контроллера ОЗУ, таким образом, проста: он служит своего рода «мостом»* между памятью и использующими ее устройствами (кстати, к ним относится не только процессор, но об этом — чуть позже). Как правило, контроллер памяти входит в состав чипсета — набора микросхем, являющегося основой системной платы. От быстродействия контроллера во многом зависит скорость обмена данными между процессором и памятью, это один из важнейших компонентов, влияющих на общую производительность компьютера.

* — кстати, контроллер памяти физически находится в микросхеме чипсета, традиционно называемой «северным мостом».

Процессорная шина

Любой процессор обязательно оснащён процессорной шиной, которую в среде x86 CPU принято называть FSB (Front Side Bus). Эта шина служит каналом связи между процессором и всеми остальными устройствами в компьютере: памятью, видеокартой, жёстким диском, и так далее. Впрочем, как мы уже знаем из предыдущего раздела, между собственно памятью и процессором находится контроллер памяти. Соответственно: процессор посредством FSB связывается с контроллером памяти, а уже тот, в свою очередь, по специальной шине (назовём её, не мудрствуя лукаво, «шиной памяти») — с модулями ОЗУ на плате. Однако, повторимся: поскольку «внешняя» шина у классического x86 CPU всего одна, она используется не только для работы с памятью, но и для общения процессора со всеми остальными устройствами.

Различия между традиционной для x86 CPU архитектурой и K8/AMD64.

Революционность подхода компании AMD состоит в том, что её процессоры с архитектурой AMD64 (и микроархитектурой, которую условно принято называть «K8») оснащены множеством «внешних» шин. При этом одна или несколько шин HyperTransport служат для связи со всеми устройствами кроме памяти, а отдельная группа из одной или двух (в случае двухканального контроллера) шин — исключительно для работы процессора с памятью. Преимущество интеграции контроллера памяти прямо в процессор, очевидно: «путь от ядра до памяти» становится заметно «короче», что позволяет работать с ОЗУ быстрее. Правда, имеются у данного подхода и недостатки. Так, например, если ранее устройства типа жёсткого диска или видеокарты могли работать с памятью через выделенный, независимый контроллер — то в случае с архитектурой AMD64 они вынуждены работать с ОЗУ через контроллер, размещённый на процессоре. Так как CPU в данной архитектуре является единственным устройством, имеющим прямой доступ к памяти. Де-факто, в противостоянии «внешний контроллер vs. интегрированный», сложился паритет: с одной стороны, на данный момент AMD является единственным производителем десктопных x86-процессоров с интегрированным контроллером памяти, с другой — компания вроде бы вполне довольна этим решением, и не собирается от него отказываться. С третьей — Intel тоже не собирается отказываться от внешнего контроллера, и вполне довольна «классической схемой», проверенной годами.

Оперативная память

Разрядность шины памяти, N-канальные контроллеры памяти

По состоянию на сегодняшний день, вся память, используемая в современных десктопных x86-системах имеет шину шириной 64 бита. Это означает, что за один такт по данной шине одновременно может быть передано количество информации, кратное 8 байтам (8 байт для SDR-шин, 16 байт для DDR-шин). Особняком стоит только память типа RDRAM, применявшаяся в системах на базе процессоров Intel Pentium 4 на заре становления архитектуры NetBurst, но сейчас это направление признано тупиковым для x86-ПК (к слову — руку к этому приложила всё та же компания Intel, которая в своё время активно пропагандировала данный тип памяти). Некоторую неразбериху вносят лишь двухканальные контроллеры, обеспечивающие одновременную работу с двумя отдельными друг от друга 64-битными шинами, благодаря чему некоторые производители заявляют о некой «128-битности». Это, разумеется, чистой воды профанация. Арифметика на уровне 1-го класса в данном случае, увы, не работает: 2x64 вовсе не равно 128. Почему? Да хотя бы потому, что даже самые современные x86 CPU (см. ниже раздел FAQ «64-битные расширения классической x86 (IA32) архитектуры») не могут работать со 128-битной шиной и 128-битной адресацией. Грубо говоря: две независимые параллельно идущие дороги, шириной 2 метра каждая — могут обеспечить одновременный проезд двух автомобилей, шириной 2 метра — но никоим образом не одного, шириной 4 метра. Точно так же, N-канальный контроллер памяти может увеличить скорость работы с данными в N раз (и то больше теоретически, чем практически) — но никак не способен увеличить разрядность этих данных. Ширина шины памяти во всех современных контроллерах, применяемых в x86-системах, равна 64 битам — независимо от того, находится этот контроллер в чипсете, или в самом процессоре. Некоторые контроллеры оснащены двумя независимыми 64-битными каналами, но на разрядность шины памяти это никак не влияет — только на скорость считывания и записи информации.

Скорость чтения и записи

Скорость чтения и записи информации в память теоретически ограничивается исключительно пропускной способностью самой памяти. Так, например, двухканальный контроллер памяти стандарта DDR400 теоретически способен обеспечить скорость чтения и записи информации, равную 8 байт (ширина шины) * 2 (количество каналов) * 2 (протокол DDR, обеспечивающий передачу 2 пакетов данных за 1 такт) * 200'000'000 (фактическая частота работы шины памяти равная 200 МГц, то есть 200'000'000 тактов в секунду). Значения, получаемые в результате практических тестов, как правило, чуть ниже теоретических: сказывается «неидеальность» конструкции контроллера памяти, плюс накладки (задержки), вызванные работой подсистемы кэширования самого процессора (см. ниже раздел про процессорный кэш). Однако основной «подвох» содержится даже не в накладках, связанных с работой контроллера и подсистемы кэширования, а в том, что скорость «линейного» чтения или записи является вовсе не единственной характеристикой, влияющей на фактическую скорость работы процессора с ОЗУ. Для того чтобы понять, из каких составляющих складывается фактическая скорость работы процессора с памятью, нам необходимо кроме линейной скорости считывания или записи учитывать ещё и такую характеристику, как латентность.

Латентность

Латентность является не менее важной характеристикой с точки зрения быстродействия подсистемы памяти, чем скорость «прокачки данных», но совершенно другой, по сути. Большая скорость обмена данными хороша тогда, когда их размер относительно велик, но если нам требуется «понемногу с разных адресов» — то на первый план выходит именно латентность. Что это такое? В общем случае — время, которое требуется для того, чтобы начать считывать информацию с определённого адреса. И действительно: с момента, когда процессор посылает контроллеру памяти команду на считывание (запись), и до момента, когда эта операция осуществляется, проходит определённое количество времени. Причём оно вовсе не равно времени, которое требуется на пересылку данных. Приняв команду на чтение или запись от процессора, контроллер памяти «указывает» ей, с каким адресом он желает работать. Доступ к любому произвольно взятому адресу не может быть осуществлён мгновенно, для этого требуется определённое время. Возникает задержка: адрес указан, но память ещё не готова предоставить к нему доступ. В общем случае, эту задержку и принято называть латентностью. У разных типов памяти она разная. Так, например, память типа DDR2 имеет в среднем гораздо большие задержки, чем DDR (при одинаковой частоте передачи данных). В результате, если данные в программе расположены «хаотично» и «небольшими кусками», скорость их считывания становится намного менее важной, чем скорость доступа к «началу куска», так как задержки при переходе на очередной адрес влияют на быстродействие системы намного сильнее, чем скорость считывания или записи.

«Соревнование» между скоростью чтения (записи) и латентностью — одна из основных головных болей разработчиков современных систем: к сожалению, рост скорости чтения (записи), почти всегда приводит к увеличению латентности. Так, например, память типа SDR (PC66, PC100, PC133) обладает в среднем лучшей (меньшей) латентностью, чем DDR. В свою очередь, у DDR2 латентность ещё выше (то есть хуже), чем у DDR.

Следует понимать, что «общая» латентность подсистемы памяти зависит не только от неё самой, но и от контроллера памяти и места его расположения — все эти факторы тоже влияют на задержку. Именно поэтому компания AMD в процессе разработки архитектуры AMD64 решила «одним махом» решить проблему высокой латентности, интегрировав контроллер прямо в процессор — чтобы максимально «сократить дистанцию» между процессорным ядром и модулями ОЗУ. Затея удалась, но дорогой ценой: теперь система на базе определённого CPU архитектуры AMD64 может работать только с той памятью, на которую рассчитан его контроллер. Наверное, именно поэтому компания Intel до сих пор не решилась на такой кардинальный шаг, предпочитая действовать традиционными методами: усовершенствуя контроллер памяти в чипсете и механизм Prefetch в процессоре (про него см. ниже).

В завершение, заметим, что понятия «скорость чтения / записи» и «латентность», в общем случае, применимы к любому типу памяти — в том числе не только к классической DRAM (SDR, Rambus, DDR, DDR2), но и к кэшу (см. ниже).

Процессор: сведения общего характера

Понятие архитектуры

Архитектура как совместимость с кодом

Наверняка вы часто встречались с термином «x86», или «Intel-совместимый процессор» (или «IBM PC compatible» — но это уже по отношению к компьютеру). Иногда также встречается термин «Pentium-совместимый» (почему именно Pentium — вы поймете сами чуть позже). Что за всеми этими названиями скрывается на самом деле? На данный момент наиболее корректно с точки зрения автора выглядит следующая простая формулировка: современный x86-процессор — это процессор, способный корректно исполнять машинный код архитектуры IA32 (архитектура 32-битных процессоров Intel). В первом приближении это код, исполняемый процессором i80386 (известным в народе как «386-й»), окончательно же основной набор команд IA32 сформировался с выходом процессора Intel Pentium Pro. Что означает «основной набор» и какие есть еще? Для начала ответим на первую часть вопроса. «Основной» в данном случае означает то, что с помощью исключительно этого набора команд, может быть написана любая программа, которая вообще может быть написана для процессора архитектуры x86 (или IA32, если вам так больше нравится).

Кроме того, у архитектуры IA32 существуют «официальные» расширения (дополнительные наборы команд) от разработчика самой архитектуры, компании Intel: MMX, SSE, SSE2 и SSE3. Также существуют «неофициальные» (не от Intel) расширенные наборы команд: EMMX, 3DNow! и Extended 3DNow! — их разработала компания AMD. Впрочем, «официальность» и «неофициальность» в данном случае понятие относительное — де-факто все сводится к тому, что некоторые расширения набора команд Intel как разработчик изначального набора признает, а некоторые — нет, разработчики же программного обеспечения используют то, что им лучше всего подходит. В отношении расширенных наборов команд существует одно простое правило хорошего тона: прежде чем их использовать, программа должна проверить, поддерживает ли их процессор. Иногда отступления от этого правила встречаются (и могут приводить к неправильному функционированию программ), но объективно это является проблемой некорректно написанного программного обеспечения, а не процессора.

Для чего предназначены дополнительные наборы команд? В первую очередь — для увеличения быстродействия при выполнении некоторых операций. Одна команда из дополнительного набора, как правило, выполняет действие, для которого понадобилась бы небольшая программа, состоящая из команд основного набора. Опять-таки, как правило, одна команда выполняется процессором быстрее, чем заменяющая ее последовательность. Однако в 99% случаев, ничего такого, чего нельзя было бы сделать с помощью основных команд, с помощью команд из дополнительного набора сделать нельзя. Таким образом, упомянутая выше проверка программой поддержки дополнительных наборов команд процессором, должна выполнять очень простую функцию: если, например, процессор поддерживает SSE — значит, считать будем быстро и с помощью команд из набора SSE. Если нет — будем считать медленнее, с помощью команд из основного набора. Корректно написанная программа обязана действовать именно так. Впрочем, сейчас практически никто не проверяет у процессора наличие поддержки MMX, так как все CPU, вышедшие за последние 5 лет, этот набор поддерживают гарантированно. Для справки приведем табличку, на которой обобщена информация о поддержке различных расширенных наборов команд различными десктопными (предназначенными для настольных ПК) процессорами.

Процессор MMX. EMMX. 3DNow! SSE. E3DNow! SSE2. SSE3. Intel Pentium II. + Intel Celeron до 533 MHz. + Intel Pentium III. + + Intel Celeron 533—1400 MHz. + + Intel Pentium 4. + + + +/—* Intel Celeron от 1700 MHz. + + + Intel Celeron D. + + + + Intel Pentium 4 eXtreme Edition. + + + +/—* Intel Pentium eXtreme Edition. + + + + Intel Pentium D. + + + + AMD K6. + + AMD K6-2. + + + AMD K6-III. + + + AMD Athlon. + + + + AMD Duron до 900 MHz. + + + + AMD Athlon XP. + + + + + AMD Duron от 1000 MHz. + + + + + AMD Athlon 64 / Athlon FX. + + + + + + +/—* AMD Sempron. + + + + + +/—* +/—* AMD Athlon 64 X2. + + + + + + + VIA C3. + + +/—* +/—*

* в зависимости от модификации

На данный момент всё популярное десктопное программное обеспечение (операционные системы Windows и Linux, офисные пакеты, компьютерные игры, и прочее) разрабатывается именно для x86-процессоров. Оно выполняется (за исключением «дурно воспитанных» программ) на любом x86-процессоре, независимо от того, кто его произвел. Поэтому вместо ориентированных на разработчика изначальной архитектуры терминов «Intel-совместимый» или «Pentium-совместимый», стали употреблять нейтральное название: «x86-совместимый процессор», «процессор с архитектурой x86». В данном случае под «архитектурой» понимается совместимость с определённым набором команд, то есть, можно сказать, «архитектура процессора с точки зрения программиста». Есть и другая трактовка того же термина.

Архитектура как характеристика семейства процесcоров

«Железячники» — люди, работающие в основном не с программным обеспечением, а с аппаратным, под «архитектурой» понимают несколько другое (правда, более корректно то, что они называют «архитектурой», называется «микроархитектурой», но де-факто приставку «микро» частенько опускают). Для них «архитектура CPU» — это некий набор свойств, присущий целому семейству процессоров, как правило, выпускаемому в течение многих лет (иначе говоря — «внутренняя конструкция», «организация» этих процессоров). Так, например, любой специалист по x86 CPU вам скажет, что процессор с ALU, работающими на удвоенной частоте, QDR-шиной, Trace cache, и, возможно, поддержкой технологии Hyper-Threading — это «процессор архитектуры NetBurst» (не пугайтесь незнакомых терминов — все они будут разъяснены чуть позже). А процессоры Intel Pentium Pro, Pentium II и Pentium III — это «архитектура P6». Таким образом, понятие «архитектуры» применительно к процессорам несколько двойственно: под ним может пониматься как совместимость с неким единым набором команд, так и совокупность аппаратных решений, присущих определённой достаточно широкой группе процессоров. Разумеется, такой дуализм одного из основополагающих понятий не очень удобен, однако так уж сложилось, и вряд ли в ближайшее время что-то поменяется...

64-битные расширения классической x86 (IA32) архитектуры

Не так давно оба ведущих производителя x86 CPU анонсировали две практически идентичных* технологии (впрочем, AMD предпочитает называть это архитектурой), благодаря которым классические x86 (IA32) CPU получили статус 64-битных. В случае с AMD данная технология получила наименование «AMD64» (64-битная архитектура AMD), в случае с Intel — «EM64T» (расширенная 64-битная технология работы с памятью). Также почтенные аксакалы, знакомые с историей вопроса, иногда употребляют наименование «x86-64» — как общее обозначение всех 64-битных расширений архитектуры x86, не привязанное к зарегистрированным торговым маркам какого-либо производителя. Де-факто, употребление одного из трёх, приведенных выше, наименований, зависит больше от личных предпочтений употребляющего, чем от фактических различий — ибо различия между AMD64 и EM64T умещаются на кончике очень тонкой иглы. К тому же, сама AMD ввела «фирменное» наименование «AMD64» лишь незадолго до анонса собственных процессоров на основе данной архитектуры, а до этого совершенно спокойно употребляла в собственных документах более нейтральное «x86-64». Однако так или иначе, всё сводится к одному: некоторые внутренние регистры процессоров стали вместо 32-битных 64-битными, 32-битные команды x86-кода получили свои 64-битные аналоги, кроме того, объём адресуемой памяти (включая не только физическую, но и виртуальную) многократно увеличился (за счёт того, что адрес приобрёл вместо 32-битного 64-битный формат). Количество маркетинговых спекуляций на тему «64-битности» превысило все разумные пределы, поэтому нам следует рассмотреть достоинства данного нововведения особенно пристально. Итак: что же на самом деле изменилось, а что — нет?

* — Доводы о том, что Intel, дескать, «нагло скопировала EM64T с AMD64» не выдерживают никакой критики. И вовсе не потому, что это не так — а потому, что вовсе не «нагло». Есть такое понятие: «кросс-лицензионное соглашение». Если таковое соглашение имеет место быть, это означает, что все разработки одной компании в определённой области, становятся автоматически доступными другой, равно как и разработки другой автоматически становятся доступны первой. Intel воспользовалась кросс-лицензированием для разработки EM64T, взяв за основу AMD64 (чего никто никогда не отрицал). AMD воспользовалась тем же соглашением для введения в свои процессоры поддержки наборов дополнительных инструкций SSE2 и SSE3, разработанных Intel. И ничего в этом постыдного нет: раз договорились «делиться» разработками — значит, надо делиться.

Что не изменилось? В первую очередь — быстродействие процессоров. Вопиющей глупостью будет считать, что один и тот же процессор при переходе из привычного 32-битного в 64-битный режим (а 32-битный режим все нынешние x86 CPU поддерживают в обязательном порядке) станет работать в 2 раза быстрее. Разумеется, в некоторых случаях некое ускорение от использования 64-битной целочисленной арифметики может присутствовать — но количество этих случаев сильно ограничено, и большинства современного пользовательского программного обеспечения они никак не касаются. Кстати: а почему мы употребили термин «64-битная целочисленная арифметика»? А потому, что блоки операций с плавающей точкой (см. ниже) во всех x86-процессорах уже давным-давно не 32-битные. И даже не 64-битные. Классический x87 FPU (см. ниже), окончательно ставший частью CPU ещё во времена старого доброго 32-битного Intel Pentium — уже был 80-битным. Операнды команд SSE и SSE2/3 — и вовсе 128-битные! В этом плане архитектура x86 достаточно парадоксальна: при всём притом, что формально процессоры данной архитектуры достаточно долгое время оставались 32-битными — разрядность тех блоков, где «большая битность» была реально необходима — наращивалась совершенно независимо от остальных. Например, процессоры AMD Athlon XP и Intel Pentium 4 «Northwood» совмещали в себе блоки, работающие с 32-битными, 80-битными, и 128-битными операндами. 32-битными оставались лишь основной набор команд (унаследованный от первого процессора архитектуры IA32 — Intel 386) и адресация памяти (максимум 4 гигабайта, если не считать «извращений» типа Intel PAE).

Таким образом, то, что процессоры AMD и Intel стали «формально 64-битными», на практике принесло нам лишь три усовершенствования: появление команд для работы с 64-битными целыми числами, увеличение количества и/или разрядности регистров, и увеличение максимального объёма адресуемой памяти. Заметим: реальной пользы этих нововведений (особенно третьего!) никто не отрицает. Равно как никто не отрицает заслуг компании AMD в продвижении идеи «осовременивания» (за счёт введения 64-битности) x86-процессоров. Мы лишь хотим предостеречь от чрезмерных ожиданий: не стоит надеяться на то, что компьютер, покупавшийся «в ценовом классе ВАЗа», от установки 64-битного программного обеспечения станет «лихим Мерседесом». Чудес на свете не бывает...

Процессорное ядро

Различия между ядрами одной микроархитектуры

«Процессорное ядро» (как правило, для краткости его называют просто «ядро») — это конкретное воплощение [микро]архитектуры (т.е. «архитектуры в аппаратном смысле этого слова»), являющееся стандартом для целой серии процессоров. Например, NetBurst — это микроархитектура, которая лежит в основе многих сегодняшних процессоров Intel: Celeron, Pentium 4, Xeon. Микроархитектура задает общие принципы: длинный конвейер, использование определенной разновидности кэша кода первого уровня (Trace cache), прочие «глобальные» особенности. Ядро — более конкретное воплощение. Например, процессоры микроархитектуры NetBurst с шиной 400 МГц, кэшем второго уровня 256 килобайт, и без поддержки Hyper-Threading — это более-менее полное описание ядра Willamette. А вот ядро Northwood имеет кэш второго уровня уже 512 килобайт, хотя также основано на NetBurst. Ядро AMD Thunderbird основано на микроархитектуре K7, но не поддерживает набор команд SSE, а вот ядро Palomino — уже поддерживает.

Таким образом, можно сказать что «ядро» – это конкретное воплощение определенной микроархитектуры «в кремнии», обладающее (в отличие от самой микроархитектуры) определенным набором строго обусловленных характеристик. Микроархитектура — аморфна, она описывает общие принципы построения процессора. Ядро — конкретно, это микроархитектура, «обросшая» всевозможными параметрами и характеристиками. Чрезвычайно редки случаи, когда процессоры сменяли микроархитектуру, сохраняя название. И, наоборот, практически любое наименование процессора хотя бы несколько раз за время своего существования «меняло» ядро. Например, общее название серии процессоров AMD — «Athlon XP» — это одна микроархитектура (K7), но целых четыре ядра (Palomino, Thoroughbred, Barton, Thorton). Разные ядра, построенные на одной микроархитектуре, могут иметь, в том числе разное быстродействие.

Ревизии

Ревизия — одна из модификаций ядра, крайне незначительно отличающаяся от предыдущей, почему и не заслуживает звания «нового ядра». Как правило, из выпусков очередной ревизии производители процессоров не делают большого события, это происходит «в рабочем порядке». Так что даже если вы покупаете один и тот же процессор, с полностью аналогичным названием и характеристиками, но с интервалом где-то в полгода — вполне возможно, фактически он будет уже немного другой. Выпуск новой ревизии, как правило, связан с какими-то мелкими усовершенствованиями. Например, удалось чуть-чуть снизить энергопотребление, или понизить напряжение питания, или еще что-то оптимизировать, или была устранена пара мелких ошибок. С точки зрения производительности мы не помним ни одного примера, когда бы одна ревизия ядра отличалась от другой настолько существенно, чтобы об этом имело смысл говорить. Хотя чисто теоретически возможен и такой вариант — например, подвергся оптимизации один из блоков процессора, ответственный за исполнение нескольких команд. Подводя итог, можно сказать что «заморачиваться» ревизиями процессоров чаще всего не стоит: в очень редких случаях изменение ревизии вносит какие-то кардинальные изменения в процессор. Достаточно просто знать, что есть такая штука — исключительно для общего развития.

Частота работы ядра

Как правило, именно этот параметр в просторечии именуют «частотой процессора». Хотя в общем случае определение «частота работы ядра» всё же более корректно, так как совершенно не обязательно все составляющие CPU функционируют на той же частоте, что и ядро (наиболее частым примером обратного являлись старые «слотовые» x86 CPU — Intel Pentium II и Pentium III для Slot 1, AMD Athlon для Slot A — у них L2-кэш функционировал на 1/2, и даже иногда на 1/3 частоты работы ядра). Ещё одним распространённым заблуждением является уверенность в том, что частота работы ядра однозначным образом определяет производительность. На самом деле это дважды не так: во-первых, каждое конкретное процессорное ядро (в зависимости от того, как оно спроектировано, сколько содержит исполняющих блоков различных типов, и т.д. и т.п.) может исполнять различное количество команд за один такт, частота же — это всего лишь количество таких тактов в секунду. Таким образом (приведенное далее сравнение, разумеется, очень сильно упрощено и поэтому весьма условно) процессор, ядро которого исполняет 3 инструкции за такт, может иметь на треть меньшую частоту, чем процессор, исполняющий 2 инструкции за такт — и при этом обладать полностью аналогичным быстродействием.

Во-вторых, даже в рамках одного и того же ядра, увеличение частоты вовсе не всегда приводит к пропорциональному увеличению быстродействия. Здесь вам очень пригодятся знания, которые вы могли почерпнуть из раздела «Общие принципы взаимодействия процессора и ОЗУ». Дело в том, что скорость исполнения команд ядром процессора — это вовсе не единственный показатель, влияющий на скорость выполнения программы. Не менее важна скорость поступления команд и данных на CPU. Представим себе чисто теоретически такую систему: быстродействие процессора — 10'000 команд в секунду, скорость работы памяти — 1000 байт в секунду. Вопрос: даже если принять, что одна команда занимает не более одного байта, а данных у нас нет совсем, с какой скоростью будет исполняться программа в такой системе? Правильно: не более 1000 команд в секунду, и производительность CPU тут совершенно ни при чём: мы будем ограничены не ей, а скоростью поступления команд в процессор. Таким образом, следует понимать: невозможно непрерывно наращивать одну только частоту ядра, не ускоряя одновременно подсистему памяти, так как в этом случае начиная с определённого этапа, увеличение частоты CPU перестанет сказываться на увеличении быстродействия системы в целом.

Особенности образования названий процессоров

Раньше, когда небо было голубее, пиво — вкуснее, а девушки — красивее, процессоры называли просто: имя производителя + название модельного ряда + частота. Например: «AMD K6-2 450 MHz». В настоящее время уже оба основных производителя от этой традиции отошли, и вместо частоты употребляют какие-то непонятные циферки, обозначающие невесть что. Краткому объяснению того, что же на самом деле эти циферки обозначают, и посвящены следующие два раздела.

Рейтинги от AMD.

Причина, по которой компания AMD «изъяла» частоту из наименования своих процессоров, и заменила её некой абстрактной цифрой — общеизвестна: после появления процессора Intel Pentium 4, который работает на очень высоких частотах, процессоры AMD рядом с ним стали «плохо выглядеть на витрине» — покупатель не верил, что CPU с частотой, например, 1500 МГц, может обогнать CPU с частотой 2000 МГц. Поэтому частоту в наименовании заменили рейтингом. Формальная («де-юре», так сказать) трактовка этого рейтинга в устах AMD в разные времена звучала немного по-разному, но ни разу не прозвучала в том виде, в каком её воспринимали пользователи: процессор AMD с неким рейтингом, должен быть как минимум не медленнее процессора Intel Pentium 4 с соответствующей данному рейтингу частотой. Между тем, ни для кого не являлось особенным секретом, что именно такая трактовка и являлась конечной целью введения рейтинга. В общем, все всё прекрасно понимали, но AMD старательно делала вид, что она тут ни при чём :). Пенять ей за это не стоит: в конкурентной борьбе применяются совсем другие правила, чем в рыцарских поединках. Тем более что результаты независимых тестов демонстрировали: в целом, рейтинги своим процессорам AMD назначает достаточно справедливые. Собственно, именно до тех пор, пока это так — вряд ли имеет смысл протестовать против использования рейтинга. Правда, остаётся открытым один вопрос: а к чему же (нас интересует, понятное дело, состояние де-факто, а не разъяснения маркетингового отдела) будет привязан рейтинг процессоров AMD чуть позже, когда вместо Pentium 4 Intel начнёт выпускать какой-нибудь другой процессор?

Processor Number от Intel.

Что нужно запомнить сразу: Processor Number (далее PN) у процессоров Intel — это не рейтинг. Не рейтинг производительности, и не рейтинг чего-либо другого. Фактически, это просто «артикул», элемент строчки в складской ведомости, единственная задача которого — сделать так, чтобы строчка, обозначающая один процессор, отличалась от строчки, обозначающей другой. В рамках серии (первая цифра PN), две остальные цифры, в принципе, кое о чём могут сказать, но, учитывая наличие таблиц, в которых приведено полное соответствие между PN и реальными параметрами, мы не видим особого смысла в том, чтобы заучивать какие-то промежуточные соответствия. Мотивация, которой руководствовалась Intel, вводя PN (вместо опять-таки указания частоты CPU) — более сложная, чем у AMD. Необходимость введения PN (как её объясняет сама Intel) связана, прежде всего, с тем, что два основных конкурента по-разному подходят к вопросу об уникальности наименования CPU. Например, у AMD название «Athlon 64 3200+» может обозначать сразу четыре процессора с несколько различными техническими характеристиками (но одинаковым «рейтингом»). Intel придерживается мнения, что наименование процессора должно быть уникальным, в связи с чем ранее компании приходилось «изворачиваться», добавляя к значению частоты в наименовании различные буквы, и это приводило к путанице. По идее, PN должен был эту путаницу устранить. Трудно сказать, была ли достигнута поставленная цель: всё равно номенклатура процессоров Intel осталась достаточно сложной. С другой стороны, это неизбежно, так как ассортимент продуктов уж больно велик. Однако независимо от всего прочего, одного эффекта де-факто добиться точно удалось: теперь только разбирающиеся в вопросе специалисты могут по названию процессора быстро и точно «по памяти» сказать, что он собой представляет, и какова будет его производительность в сравнении с другими CPU. Насколько это хорошо? Сложно сказать. Мы предпочтём воздержаться от комментариев.

Измерение скорости «в мегагерцах» — как это возможно?

Никак это невозможно, потому что скорость не измеряется в мегагерцах, как не измеряется расстояние в килограммах. Однако господа маркетологи давно уже поняли, что в словесном поединке между физиком и психологом побеждает всегда последний — причём независимо от того, кто на самом деле прав. Поэтому мы и читаем про «сверхбыструю 1066 MHz FSB», мучительно пытаясь понять, как скорость может измеряться с помощью частоты. На самом деле, раз уж прижилась такая извращённая тенденция, нужно просто чётко представлять себе, что имеется в виду. А имеется в виду следующее: если мы «закрепим» ширину шины на N битах — то её пропускная способность действительно будет зависеть от того, на какой частоте данная шина функционирует, и какое количество данных она способна передавать за такт. По обычной процессорной шине с «одинарной» скоростью (такая шина была, например, у процессора Intel Pentium III) за такт передаётся 64 бита, то есть 8 байт. Соответственно, если рабочая частота шины равна 100 МГц (100'000'000 тактов в секунду) — то скорость передачи данных будет равна 8 байт * 100'000'000 герц ~= 763 мегабайта в секунду (а если считать в «десятичных мегабайтах», в которых принято считать потоки данных, то ещё красивее — 800 мегабайт в секунду). Соответственно, если на тех же 100 мегагерцах работает DDR-шина, способная передавать за один такт удвоенный объём данных — скорость вырастет ровно вдвое. Поэтому, согласно парадоксальной логике господ маркетологов, данную шину следует именовать «200-мегагерцевой». А если это ещё и QDR (Quad Data Rate) шина — то она и вовсе «400-мегагерцевая» получается, так как за один такт передаёт четыре пакета данных. Хотя реальная частота работы у всех трёх вышеописанных шин одинаковая — 100 мегагерц. Вот так «мегагерцы» и стали синонимом скорости.

Таким образом, QDR-шина (с «учетверённой» скоростью), работающая на реальной частоте 266 мегагерц, волшебным образом оказывается у нас «1066-мегагерцевой». Цифра «1066» в данном случае олицетворяет то, что её пропускная способность ровно в 4 раза больше «односкоростной» шины, работающей на той же самой частоте. Вы ещё не запутались?.. Привыкайте! Это вам не какая-нибудь теория относительности, тут всё намного сложней и запущенней... Впрочем, самое главное здесь — выучить наизусть один простой принцип: если уж мы занимаемся таким извращением, как сравнение скорости двух шин между собой «в мегагерцах» — то они обязательно должны быть одинаковой ширины. Иначе получается как в одном форуме, где человек всерьёз доказывал, что пропускная способность AGP2X («133-мегагерцевая», но 32-битная шина) — выше, чем пропускная способность FSB у Pentium III 800 (реальная частота 100 МГц, ширина 64 бита).

Пара слов о некоторых пикантных особенностях DDR и QDR протоколов

Как уже было сказано выше, в режиме DDR по шине за один такт передаётся удвоенный объём информации, а в режиме QDR — учетверённый. Правда, в документах, ориентированных больше на прославление достижений производителей, чем на объективное освещение реалий, почему-то всегда забывают указать одно маленькое «но»: режимы удвоенной и учетверённой скорости включаются только при пакетной передаче данных. То есть, если мы запросили из памяти парочку мегабайтов с адреса X по адрес Y — то да, эти два мегабайта будут переданы с удвоенной/учетверённой скоростью. А вот сам запрос на данные посылается по шине с «одинарной» скоростью — всегда! Соответственно, если запросов у нас много, а размер пересылаемых данных не очень велик, то количество данных, которые «путешествуют» по шине с одинарной скоростью (а запрос — это тоже данные) будет почти равно количеству тех, которые передаются со скоростью удвоенной или учетверённой. Вроде бы нам никто открыто не врал, вроде бы DDR и QDR действительно работают, но... как говорится в одном старом анекдоте: «то ли он у кого-то украл шубу, то ли у него кто-то украл шубу, но что-то там с шубой не то...» ;).

Процессор «крупноблочно».

Кэш

Общее описание и принцип действия

Во всех современных процессорах есть кэш (по-английски — cache). Кэш — это некая особенная разновидность памяти (основная особенность, кардинально отличающая кэш от ОЗУ — скорость работы), которая является своего рода «буфером» между контроллером памяти и процессором. Служит этот буфер для увеличения скорости работы с ОЗУ. Каким образом? Сейчас попытаемся объяснить. При этом мы решили отказаться от попахивающих детским садом сравнений, которые частенько встречаются в популяризаторской литературе на процессорную тематику (бассейны, соединённые трубами разного диаметра, и т.д. и т.п.). Всё-таки человек, который дочитал статью до этого места, и не заснул — наверное, способен выдержать и «переварить» чисто техническое объяснение, без бассейнов, кошечек и одуванчиков.

Итак, представим, что у нас есть много сравнительно медленной памяти (пусть это будет ОЗУ размером 10'000'000 байт) и относительно мало очень быстрой (пусть это будет кэш размером всего 1024 байта). Как нам с помощью этого несчастного килобайта увеличить скорость работы со всей памятью вообще? А вот здесь следует вспомнить, что данные в процессе работы программы, как правило, не бездумно перекидываются с места на место — они изменяются. Считали из памяти значение какой-то переменной, прибавили к нему какое-то число — записали обратно на то же место. Считали массив, отсортировали по возрастанию — опять-таки записали в память. То есть в один какой-то момент программа работает не со всей памятью целиком, а, как правило, с относительно маленьким её фрагментом. Какое решение напрашивается? Правильно: загрузить этот фрагмент в «быструю» память, обработать его там, а потом уже записать обратно в «медленную» (или просто удалить из кэша, если данные не изменялись). В общем случае, именно так и работает процессорный кэш: любая считываемая из памяти информация попадает не только в процессор, но и в кэш. И если эта же информация (тот же адрес в памяти) нужна снова, сначала процессор проверяет: а нет ли её в кэше? Если есть — информация берётся оттуда, и обращения к памяти не происходит вовсе. Аналогично с записью: информация, если её объём влезает в кэш — пишется именно туда, и только потом, когда процессор закончил операцию записи, и занялся выполнением других команд, данные, записанные в кэш, параллельно с работой процессорного ядра «потихоньку выгружаются» в ОЗУ.

Разумеется, объём данных, прочитанных и записанных за всё время работы программы — намного больше объёма кэша. Поэтому некоторые из них приходится время от времени удалять, чтобы в кэш могли поместиться новые, более актуальные. Самый простой из известных механизмов обеспечения данного процесса — отслеживание времени последнего обращения к данным, находящимся в кэше. Так, если нам необходимо поместить новые данные в кэш, а он уже «забит под завязку», контроллер, управляющий кэшем, смотрит: к какому фрагменту кэша не происходило обращения дольше всего? Именно этот фрагмент и является первым кандидатом на «вылет», а на его место записываются новые данные, с которыми нужно работать сейчас. Вот так, в общих чертах, работает механизм кэширования в процессорах. Разумеется, приведенное выше объяснение весьма примитивно, на самом деле всё ещё сложнее, но, надеемся, общее представление о том, зачем процессору нужен кэш и как он работает, вы получить смогли.

А для того чтобы было понятно, насколько важен кэш, приведем простой пример: скорость обмена данными процессора Pentium 4 со своим кэшам более чем в 10 раз (!) превосходит скорость его работы с памятью. Фактически, в полную силу современные процессоры способны работать только с кэшем: как только они сталкиваются с необходимостью прочитать данные из памяти — все их хваленые мегагерцы начинают просто «греть воздух». Опять-таки, простой пример: выполнение простейшей инструкции процессором происходит за один такт, то есть за секунду он может выполнить такое количество простых инструкций, какова его частота (на самом деле еще больше, но это оставим на потом…). А вот время ожидания данных из памяти может в худшем случае составить более 200 тактов! Что делает процессор, пока он ждет нужных данных? А ничего он не делает. Просто стоит и ждет…

Многоуровневое кэширование

Специфика конструирования современных процессорных ядер привела к тому, что систему кэширования в подавляющем большинстве CPU приходится делать многоуровневой. Кэш первого уровня (самый «близкий» к ядру) традиционно разделяется на две (как правило, равные) половины: кэш инструкций (L1I) и кэш данных (L1D). Это разделение предусматривается так называемой «гарвардской архитектурой» процессора, которая по состоянию на сегодня является самой популярной теоретической разработкой для построения современных CPU. В L1I, соответственно, аккумулируются только команды (с ним работает декодер, см. ниже), а в L1D — только данные (они впоследствии, как правило, попадают во внутренние регистры процессора). «Над L1» стоит кэш второго уровня — L2. Он, как правило, больше по объёму, и является уже «смешанным» — там располагаются и команды, и данные. L3 (кэш третьего уровня), как правило, полностью повторяет структуру L2, и в современных x86 CPU встречается редко. Чаще всего, L3 — это плод компромисса: за счёт использование более медленной и узкой шины, его можно сделать очень большим, но при этом скорость L3 всё равно остаётся более высокой, чем скорость памяти (хотя и не такой высокой, как у L2-кэша). Тем не менее, алгоритм работы с многоуровневым кэшем в общих чертах не отличается от алгоритма работы с одноуровневым, просто добавляются лишние итерации: сначала информация ищется в L1, если её там нет — в L2, потом — в L3, и уже потом, если ни на одном уровне кэша она не найдена — идёт обращение к основной памяти (ОЗУ).

Декодер

На самом деле, исполнительные блоки всех современных десктопных x86-процессоров... вовсе не работают с кодом в стандарте x86. У каждого процессора есть своя, «внутренняя» система команд, не имеющая ничего общего с теми командами (тем самым «кодом»), которые поступают извне. В общем случае, команды, исполняемые ядром — намного проще, «примитивнее», чем команды стандарта x86. Именно для того, чтобы процессор «внешне выглядел» как x86 CPU, и существует такой блок как декодер: он отвечает за преобразование «внешнего» x86-кода во «внутренние» команды, исполняемые ядром (при этом достаточно часто одна команда x86-кода преобразуется в несколько более простых «внутренних»). Декодер является очень важной частью современного процессора: от его быстродействия зависит то, насколько постоянным будет поток команд, поступающих на исполняющие блоки. Ведь они неспособны работать с кодом x86, поэтому то, будут они что-то делать, или простаивать — во многом зависит от скорости работы декодера. Достаточно необычный способ ускорить процесс декодирования команд реализовала в процессорах архитектуры NetBurst компания Intel — см. ниже про Trace cache.

Исполняющие (функциональные) устройства

Пройдя через все уровни кэша и декодер, команды наконец-то попадают на те блоки, ради которых вся эта катавасия и устраивалась: исполняющие устройства. По сути, именно исполняющие устройства и являются единственно необходимым элементом процессора. Можно обойтись без кэша — скорость снизится, но программы работать будут. Можно обойтись без декодера — исполняющие устройства станут сложнее, но работать процессор будет. В конце концов, ранние процессоры архитектуры x86 (i8086, i80186, 286, 386, 486, Am5x86) — как-то без декодера обходились. Без исполняющих устройств обойтись невозможно, ибо именно они исполняют код программы. В самом первом приближении они традиционно делятся на две больших группы: арифметико-логические устройства (ALU) и блок вычислений с плавающей точкой (FPU).

Арифметико-логические устройства

ALU традиционно отвечают за два типа операций: арифметические действия (сложение, вычитание, умножение, деление) с целыми числами, логические операции с опять-таки целыми числами (логическое «и», логическое «или», «исключающее или», и тому подобные). Что, собственно, и следует из их названия. Блоков ALU в современных процессорах, как правило, несколько. Для чего — вы поймёте позже, прочитав раздел «Суперскалярность и внеочередное исполнение команд». Понятно, что ALU может исполнить только те команды, которые предназначены для него. Распределением команд, поступающих с декодера, по различным исполняющим устройствам, занимается специальный блок, но это уже, как говорится, «слишком сложные материи», и их вряд ли имеет смысл разъяснять в материале, который посвящен лишь поверхностному ознакомлению с основными принципами работы современных x86 CPU.

Блок вычислений с плавающей запятой*

FPU занимается выполнением команд, работающих с числами с плавающей запятой, кроме того, традиционно на него «вешают всех собак» в виде всяческих дополнительных наборов команд (MMX, 3DNow!, SSE, SSE2, SSE3...) — независимо от того, работают они с числами с плавающей запятой, или с целыми. Как и в случае с ALU, отдельных блоков в FPU может быть несколько, и они способны работать параллельно.

* — согласно традиций русской математической школы, мы называем FPU «блоком вычислений с плавающей запятой», хотя буквально его название (Floating Point Unit) переводится как «...с плавающей точкой» — согласно американскому стандарту написания таких чисел.

Регистры процессора

Регистры — по сути, те же ячейки памяти, но «территориально» они расположены прямо в процессорном ядре. Разумеется, скорость работы с регистрами во много раз превосходит как скорость работы с ячейками памяти, расположенными в основном ОЗУ (тут вообще на порядки...), так и с кэшами любого уровня. Поэтому большинство команд архитектуры x86 предусматривают осуществление действий именно над содержимым регистров, а не над содержимым памяти. Однако общий объём регистров процессора, как правило, очень мал — он не сравним даже с объёмом кэшей первого уровня. Поэтому де-факто код программы (не на языке высокого уровня, а именно бинарный, «машинный») часто содержит следующую последовательность операций: загрузить в один из регистров процессора информацию из ОЗУ, загрузить в другой регистр другую информацию (тоже из ОЗУ), произвести некое действие над содержимым этих регистров, поместив результат в третий — а потом снова выгрузить результат из регистра в основную память.

Процессор в подробностях

Особенности кэшей

Частота работы кэша и его шина

Во всех современных x86 CPU все уровни кэша работают на той же частоте, что и процессорное ядро, но это вовсе не всегда было так (данный вопрос уже поднимался выше). Однако скорость работы с кэшем зависит не только от частоты, но и от ширины шины, с помощью которой он соединён с процессорным ядром. Как вы (надеемся) помните из ранее прочитанного, скорость передачи данных является, по сути, произведением частоты работы шины (количества тактов в секунду) на количество байт, которые передаются по шине за один такт. Количество передаваемых за такт байтов можно увеличивать за счёт введения DDR и QDR (Double Data Rate и Quad Data Rate) протоколов — или просто за счёт увеличения ширины шины. В случае с кэшем более популярен второй вариант — не в последнюю очередь из-за «пикантных особенностей» DDR/QDR, описанных выше. Разумеется, минимально разумной шириной шины кэша является ширина внешней шины самого процессора, то есть, по состоянию на сегодняшний день — 64 бита. Именно так, в духе здорового минимализма, и поступает компания AMD: в её процессорах ширина шины L1 <—> L2 равна 64 битам, но при этом она двунаправленная, то есть, способна работать одновременно на передачу и приём информации. В духе «здорового гигантизма» в очередной раз поступила компания Intel: в её процессорах, начиная с Pentium III «Coppermine», шина L1 <—> L2 имеет ширину... 256 бит! По принципу «кашу маслом не испортишь», как говорится. Правда, шина эта однонаправленная, то есть в один момент времени работает либо только на передачу, либо только на приём. Споры о том, какой из подходов лучше (двунаправленная шина, но более узкая, или однонаправленная широкая) — продолжаются до сих пор... впрочем, равно как и множество других споров относительно технических решений, применяемых двумя основными конкурентами на рынке x86 CPU.

Эксклюзивный и не эксклюзивный кэш

Концепции эксклюзивного и не эксклюзивного кэширования очень просты: в случае не эксклюзивного кэша, информация на всех уровнях кэширования может дублироваться. Таким образом, L2 может содержать в себе данные, которые уже находятся в L1I и L1D, а L3 (если он есть) может содержать в себе полную копию всего содержимого L2 (и, соответственно, L1I и L1D). Эксклюзивный кэш, в отличие от не эксклюзивного, предусматривает чёткое разграничение: если информация содержится на каком-то уровне кэша — то на всех остальных она отсутствует. Плюс эксклюзивного кэша очевиден: общий размер кэшируемой информации в данном случае равен суммарному объёму кэшей всех уровней — в отличие от не эксклюзивного кэша, где размер кэшируемой информации (в худшем случае) равен объёму самого большого уровня кэша. Минус эксклюзивного кэша менее очевиден, но он есть: необходим специальный механизм, который следит за собственно «эксклюзивностью» (так, например, при удалении информации из L1-кэша, перед этим автоматически инициируется процесс её копирования в L2).

Не эксклюзивный кэш традиционно использует компания Intel, эксклюзивный (с момента появления процессоров Athlon на ядре Thunderbird) — компания AMD. В целом, мы наблюдаем здесь классическое противостояние между объёмом и скоростью: за счёт эксклюзивности, при одинаковых объёмах L1/L2 у AMD общий размер кэшируемой информации получается больше — но за счёт неё же он работает медленней (задержки, вызванные наличием механизма обеспечения эксклюзивности). Следует, наверное, заметить, что недостатки не эксклюзивного кэша компания Intel в последнее время компенсирует просто, тупо, но весомо: наращивая его объёмы. Для топовых процессоров данной компании стал уже почти что нормой L2-кэш объёмом 2 МБ — и AMD с её 128 КБ L1С+L1D и максимум 1 МБ L2 пока «не переплюнуть» эти 2 МБ даже за счёт эксклюзивности.

Кроме того, увеличивать общий объём кэшируемой информации за счёт введения эксклюзивной архитектуры кэша имеет смысл только в том случае, когда выигрыш в объёме получается достаточно большим. Для компании AMD это актуально т.к. у её сегодняшних CPU суммарный объём L1D+L1I равен 128 КБ. Процессорам Intel, у которых объём L1D равен максимум 32 КБ, а L1I иногда имеет совсем другую структуру (см. про Trace cache), введение эксклюзивной архитектуры дало бы намного меньше пользы.

А ещё есть такое распространённое заблуждение, что архитектура кэша у CPU компании Intel «инклюзивная». На самом деле — нет. Именно НЕ эксклюзивная. Инклюзивная архитектура предусматривает, что на «нижнем» уровне кэша не может находиться ничего, чего нет на более «верхнем». Не эксклюзивная архитектура всего лишь допускает дублирование данных на разных уровнях.

Trace cache.

Концепция Trace cache, состоит в том, чтобы сохранять в кэше инструкций первого уровня (L1I) не те команды, которые считаны из памяти, а уже декодированные последовательности (см. декодер). Таким образом, если некая x86-команда исполняется повторно, и она всё ещё находится в L1I, декодеру процессора не нужно снова преобразовывать её в последовательность команд «внутреннего кода», так как L1I содержит данную последовательность в уже декодированном виде. Концепция Trace cache очень удачно вписывается в общую концепцию архитектуры Intel NetBurst, ориентированную на создание процессоров с очень высокой частотой работы ядра. Однако полезность Trace cache для [относительно] менее высокочастотных CPU до сих пор находится под вопросом, так как сложность организации Trace cache становится сопоставима с задачей конструирования обычного быстрого декодера. Поэтому, отдавая должное оригинальности идеи, мы всё же сказали бы, что универсальным решением «на все случаи жизни» Trace cache считать нельзя.

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

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

1) A = B + C 2) Z = X + Y 3) K = A + Z.

Легко заметить, что команды (1) и (2) совершенно независимы друг от друга — они не пересекаются ни по исходным данным (переменные B и C в первом случае, X и Y во втором), ни по месту размещения результата (переменная A в первом случае и Z во втором). Стало быть, если на данный момент у нас есть свободные исполняющие блоки в количестве более одного, данные команды можно распределить по ним, и выполнить одновременно, а не последовательно*. Таким образом, если принять время исполнения каждой команды равным N тактов процессора, то в классическом случае исполнение всей последовательности заняло бы N*3 тактов, а в случае с параллельным исполнением — всего N*2 тактов (так как команду (3) нельзя выполнить, не дождавшись результата исполнения двух предыдущих).

* — разумеется, степень параллелизма не бесконечна: команды могут быть выполнены параллельно только в том случае, когда на данный момент времени есть в наличии соответствующее количество свободных от работы блоков (ФУ), причём именно таких, которые «понимают» рассматриваемые команды. Самый простой пример: блок, относящийся к ALU, физически неспособен исполнить инструкцию, предназначенную для FPU. Обратное также верно.

На самом деле всё ещё сложнее. Так, если у нас имеется следующая последовательность:

1) A = B + C 2) K = A + M 3) Z = X + Y.

То очередь исполнения команд процессором будет изменена! Так как команды (1) и (3) независимы друг от друга (ни по исходным данным, ни по месту размещения результата), они могут быть выполнены параллельно — и будут выполнены параллельно. А вот команда (2) будет выполнена после них (третьей) — поскольку для того, чтобы результат вычислений был корректен, необходимо, чтобы перед этим была выполнена команда (1). Именно поэтому обсуждаемый в данном разделе механизм и называется «внеочередным исполнением команд» (Out-of-Order Execution, или сокращённо «OoO»): в тех случаях, когда очерёдность выполнения никак не может сказаться на результате, команды отправляются на исполнение не в той последовательности, в которой они располагаются в коде программы, а в той, которая позволяет достичь максимального быстродействия.

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

Процессоры, оснащённые механизмом параллельного исполнения нескольких подряд идущих команд, принято называть «суперскалярными». Однако не все суперскалярные процессоры поддерживают внеочередное исполнение. Так, в первом примере нам достаточно «простой суперскалярности» (выполнения двух последовательных команд одновременно) — а вот во втором примере без перестановки команд местами уже не обойтись, если мы хотим получить максимальное быстродействие. Все современные x86 CPU обладают обоими качествами: являются суперскалярными, и поддерживают внеочередное исполнение команд. В то же время, были в истории x86 и «простые суперскаляры», OoO не поддерживающие. Например, классическим десктопным x86-суперскаляром без OoO был Intel Pentium [MMX].

Справедливости ради, стоит заметить, что никаких заслуг в разработке концепций суперскалярности и OoO — нет ни у Intel, ни у AMD, ни у какого-либо иного (в том числе из ныне почивших) производителя x86 CPU. Первый суперскалярный компьютер, поддерживающий OoO, был разработан Сеймуром Креем (Seymour Cray) ещё в 60-х годах XX века. Для сравнения: Intel свой первый суперскалярный процессор (Pentium) выпустила в 1993 году, первый суперскаляр с OoO (Pentium Pro) — в 1995 году; первый суперскаляр с OoO от AMD (K5) увидел свет в 1996 году. Комментарии, как говорится, излишни...

Предварительное (опережающее) декодирование и кэширование

Предсказание ветвлений

В любой более-менее сложной программе присутствуют команды условного перехода: «Если некое условие истинно — перейти к исполнению одного участка кода, если нет — другого». С точки зрения скорости выполнения кода программы современным процессором, поддерживающим внеочередное исполнение, любая команда условного перехода — воистину бич божий. Ведь до тех пор, пока не станет известно, какой участок кода после условного перехода окажется «актуальным» — его невозможно начать декодировать и исполнять (см. внеочередное исполнение). Для того чтобы как-то примирить концепцию внеочередного исполнения с командами условного перехода, предназначается специальный блок: блок предсказания ветвлений. Как понятно из его названия, занимается он, по сути, «пророчествами»: пытается предсказать, на какой участок кода укажет команда условного перехода, ещё до того, как она будет исполнена. В соответствии с указаниями «штатного внутриядерного пророка», процессором производятся вполне реальные действия: «напророченный» участок кода загружается в кэш (если он там отсутствует), и даже начинается декодирование и выполнение его команд. Причём среди выполняемых команд также могут содержаться инструкции условного перехода, и их результаты тоже предсказываются, что порождает целую цепочку из пока не проверенных предсказаний! Разумеется, если блок предсказания ветвлений ошибся, вся проделанная в соответствии с его предсказаниями работа просто аннулируется.

На самом деле, алгоритмы, по которым работает блок предсказания ветвлений, вовсе не являются шедеврами искусственного интеллекта. Преимущественно они просты... и тупы. Ибо чаще всего команда условного перехода встречается в циклах: некий счётчик принимает значение X, и после каждого прохождения цикла значение счётчика уменьшается на единицу. Соответственно, до тех пор, пока значение счётчика больше нуля — осуществляется переход на начало цикла, а после того, как он становится равным нулю — исполнение продолжается дальше. Блок предсказания ветвлений просто анализирует результат выполнения команды условного перехода, и считает, что если N раз подряд результатом стал переход на определённый адрес — то и в N+1 случае будет осуществлён переход туда же. Однако, несмотря на весь примитивизм, данная схема работает просто замечательно: например, в случае, если счётчик принимает значение 100, а «порог срабатывания» предсказателя ветвлений (N) равен двум переходам подряд на один и тот же адрес — легко заметить, что 97 переходов из 98 будут предсказаны правильно!

Разумеется, несмотря на достаточно высокую эффективность простых алгоритмов, механизмы предсказания ветвлений в современных CPU всё равно постоянно совершенствуются и усложняются — но тут уже речь идёт о борьбе за единицы процентов: например, за то, чтобы повысить эффективность работы блока предсказания ветвлений с 95 процентов до 97, или даже с 97% до 99...

Предвыборка данных

Блок предвыборки данных (Prefetch) очень похож по принципу своего действия на блок предсказания ветвлений — с той только разницей, что в данном случае речь идёт не о коде, а о данных. Общий принцип действия такой же: если встроенная схема анализа доступа к данным в ОЗУ решает, что к некоему участку памяти, ещё не загруженному в кэш, скоро будет осуществлён доступ — она даёт команду на загрузку данного участка памяти в кэш ещё до того, как он понадобится исполняемой программе. «Умно» (результативно) работающий блок предвыборки позволяет существенно сократить время доступа к нужным данным, и, соответственно, повысить скорость исполнения программы. К слову: грамотный Prefetch очень хорошо компенсирует высокую латентность подсистемы памяти, подгружая нужные данные в кэш, и тем самым, нивелируя задержки при доступе к ним, если бы они находились не в кэше, а в основном ОЗУ.

Однако, разумеется, в случае ошибки блока предвыборки данных, неизбежны негативные последствия: загружая де-факто «ненужные» данные в кэш, Prefetch вытесняет из него другие (быть может, как раз нужные). Кроме того, за счёт «предвосхищения» операции считывания, создаётся дополнительная нагрузка на контроллер памяти (де-факто, в случае ошибки — совершенно бесполезная).

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

Заключение

Я — тот кролик, который не может начать жевать траву до тех пор, пока не поймёт во всех деталях, как происходит процесс фотосинтеза! (изложение личной позиции одним из близких знакомых автора).

Вполне возможно, те чувства, которые у вас возникли после прочтения данной статьи, можно описать примерно следующим образом: «Вместо того чтобы на пальцах объяснить, какой процессор лучше — взяли и загрузили мне мозги кучей специфической информации, в которой ещё разбираться и разбираться, и конца-края не видно!» Вполне нормальная реакция: поверьте, мы вас хорошо понимаем. Скажем даже больше (и пусть с головы упадёт корона!): если вы думаете, что мы сами можем ответить на этот простецкий вопрос («какой процессор лучше?») — то вы очень сильно заблуждаетесь. Не можем. Для одних задач лучше один, для других — другой, а тут ещё цена разная, доступность, симпатии конкретного пользователя к определённым маркам... Не имеет задача однозначного решения. Если бы имела — наверняка кто-то бы его нашёл, и стал бы самым знаменитым обозревателем за всю историю независимых тестовых лабораторий.

Хотелось бы подчеркнуть ещё раз: даже полностью усвоив и осмыслив всю информацию, изложенную в данном материале — вы по-прежнему не сможете предсказать, какой из двух процессоров будет быстрее в ваших задачах, глядя только на их характеристики. Во-первых — потому, что далеко не все характеристики процессоров здесь рассмотрены. Во-вторых — потому, что есть и такие параметры CPU, которые в числовом виде могут быть представлены только с очень большой «натяжкой». Так для кого же (и для чего) всё это написано? В основном — для тех самых «кроликов», которые непременно желают знать, что происходит внутри тех устройств, которыми они пользуются ежедневно. Зачем? Может, они просто лучше себя чувствуют, когда знают, что вокруг них происходит? :).

Станислав Гарматюк (nawhi@ixbt.com).

©Drkb::01440.

Буферы для потоков

Стандартные потоки, широко применяющиеся в Delphi, резко упрощают повседневную работу с потоковыми данными. Но и у них есть недостаток. Дело в том, что в VCL потоки, и, главное, их базовый класс TStream, реализованы "в лоб": без всяких хитростей данные немедленно препровождаются по назначению (например, в файл). И такие операции занимают весьма значительное время (многие сотни машинных команд). Хорошо, если надо работать с "крупными" данными (килобайт и выше) - а если данные небольшие и разнообразные, замедление достигает 100 и более раз (на типе Char).

Стандартный способ ускорения подобных операций - работа с массивами элементов, вводя-выводя их в/из потока сразу. Но, во-первых, это значительно сложнее поэлементных операций, а во-вторых, если элементы имеют непостоянную длину, становится ещё сложнее. Делая небольшое отступление, замечу, что стандартная библиотека потокового ввода-вывода в большинстве реализаций C++ сделана не так - там потоки могут сами буферизовать передаваемые данные. Не понимаю, почему в Borland решили обойтись без этого. Единственное приходящее в голову объяснение - они твёрдо рассчитывали на "крупный" и "средний" обмен данными, который оптимально производить как раз без буферизации. Действительно, если посмотреть на C++ - сразу кружится голова от количества команд, необходимых для обслуживания буфера. Связано это с тем, что потоки могут попеременно читаться и писаться, а кроме того, одновременно использоваться многими потоками кода.

Ввиду этих проблем мной были написаны сравнительно простые буферные классы (работают на Delphi версий 4-5, должны работать и на последующих, а вот 3 версия уже не поддерживает перегрузку методов - в принципе, переписать и тут несложно), позволяющие производить буферизованный обмен с любыми потоками. В целях максимального ускорения работы классы эти, во-первых, не "thread-safe", а во-вторых, это два разных класса - для записи и для чтения - унаследованных от одного базового (кроме TObject, разумеется). Классы "пристёгиваются" к потоку (кстати, в C++ это делается практически так же) - и пользуются ими только для "крупного" обмена, осуществляя "мелкий" самостоятельно со своим буфером.

Code: 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( {присоединённый поток, меняется свойством Stream}. Const Stream: TStream; 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( {присоединённый поток, меняется свойством Stream}. Const Stream: TStream; 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;

Замена Application.ProcessMessages.

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Замена штатного Application.ProcessMessages. Хорошо использовать в DLL или бесформенных приложениях, Если внутри цикла возникает необходимость в использовании Application.ProcessMessages. Зависимости: Windows, Messages. Автор: ssk, ucad@pisem.net, ICQ:166758074, Харьков. Copyright: составлено из кусков кода Borland. Дата: 7 сентября 2004 г. ***************************************************** } Procedure ProcessMessagesEx; Function IsKeyMsg(var Msg: TMsg): Boolean; Const. CN_BASE = $BC00; Var. Wnd: HWND; Begin. Result := False; With Msg do. If (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then. Begin. Wnd := GetCapture; If Wnd = 0 then. Begin. Wnd := HWnd; If SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then. Result := True; End. Else. If (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then. If SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then. Result := True; End; End; Function ProcessMessage(var Msg: TMsg): Boolean; Begin. Result := False; If PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then. Begin. Result := True; If Msg.Message <> WM_QUIT then. If not IsKeyMsg(Msg) then. Begin. TranslateMessage(Msg); DispatchMessage(Msg); End; End; End; Var. Msg: TMsg; Begin. While ProcessMessage(Msg) do {loop}; End;

Array of Byte --> TMemoryStream.

Code: Procedure TForm1.Button2Click(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Const. Start = 49; AnEnd = 57; ArLen = AnEnd - Start + 1; Var. M: TMemoryStream; Buff: array of Byte; I: Integer; Begin. SetLength(Buff, ArLen); For I := 0 to ArLen - 1 do. Buff[I] := Start + I; M := TMemoryStream.Create; Try. M.Write(Buff[0], ArLen); M.SaveToFile('c:\test.txt'); Finally. M.Free; End; End;

В результате должен получится файл c:\test.txt такого содержания:

123456789.

поскольку числа с 49 до 51 являются ASCII-кодами этих чисел, а соответственно и являются их символьным представлением.

©Drkb::00252.

Автор: s-mike

Array --> String.

Code: 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;

©Drkb::00797.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

String --> Array.

Code: Procedure AssignFixedString( Var FixedStr: Array of Char; Const S: String. ); Var. Maxlen: Integer; Begin. Maxlen := Succ( High( FixedStr ) - Low( FixedStr )); FillChar( FixedStr, maxlen, ' ' ); { blank fixed string }. If Length(S) > maxlen Then. Move( S[1], FixedStr, maxlen ). Else. Move( S[1], FixedStr, Length(S)); End;

©Drkb::00253.

Code: 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;

©Drkb::00796.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Ascii --> String.

Выравнивание колонок StringGrid.

Автор: Kurt.

Выравнивание по центру в TEdit?

TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.

Выравнивание текста в ячейке Excel.

Выравнивание текста в ячейке

Следующим шагом изменения режима отображения данных в ячейках книги Excel рассмотрим выравнивание текста по горизонтали и вертикали. Для выравнивания по горизонтали используется свойство HorizontalAlignment объекта Range, которое применяем в функции SetHorizontalAlignment. Если записывать в аргумент alignment:integer этой функции определенные числовые константы, то получим различные варианты выравнивания текста по горизонтали. Смотрите список констант и функцию, реализующую выравнивание текста по горизонтали.

Code: Const. XlHAlignCenter=-4108; XlHAlignDistributed=-4117; XlHAlignJustify=-4130; XlHAlignLeft=-4131; XlHAlignRight=-4152; XlHAlignCenterAcrossSelection=7; XlHAlignFill=5; XlHAlignGeneral=1; Function SetHorizontalAlignment (sheet:variant;range:string; Alignment:integer):boolean; Begin. SetHorizontalAlignment:=true; Try. E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].HorizontalAlignment:=alignment; Except. SetHorizontalAlignment:=false; End; End;

Выравнивание текста в TRichEdit.

Code: Uses. RichEdit; // Using the Paragraph property. Procedure RE_AlignText1(ARichEdit: TRichEdit; alignment: TAlignment); Begin. ARichEdit.Paragraph.Alignment := alignment; End; // Using PARAFORMAT2; nonVCL. Procedure RE_AlignText2(ARichEdit: TRichEdit; alignment: TAlignment); Var. Pf2: PARAFORMAT2; Begin. FillChar(pf2, SizeOf(pf2), 0); Pf2.cbSize := SizeOf(PARAFORMAT2); SendMessage(ARichEdit.Handle, EM_GETPARAFORMAT, 0, Longint(@pf2)); Pf2.dwMask := PFM_ALIGNMENT; Case alignment of. TaLeftJustify: pf2.wAlignment := PFA_LEFT; TaCenter: pf2.wAlignment := PFA_CENTER; TaRightJustify: pf2.wAlignment := PFA_RIGHT; End; SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2)); End; // Example: Right align text. // Beispiel: Text rechtsbundig ausrichten. Procedure TForm1.Button1Click(Sender: TObject); Begin. RE_AlignText2(RichEdit1, taRightJustify); End;

Выравнивание текста по ширине

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

Вывести Bitmap на рабочем столе

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Picture: TPicture; Desktop: TCanvas; X, Y: Integer; Begin. // Objekte erstellen. // create objects. Picture := TPicture.Create; Desktop := TCanvas.Create; // Bild laden. // load bitmap. Picture.LoadFromFile('bitmap1.bmp'); // Geratekontex vom Desktop ermitteln. // get DC of desktop. Desktop.Handle := GetWindowDC(0); // Position des Bildes. // position of bitmap. X := 100; Y := 100; // Bild zeichnen. // draw bitmap. Desktop.Draw(X, Y, Picture.Graphic); // Geratekontex freigeben. ReleaseDC(0, Desktop.Handle); // Objekte freigeben. // release objects. Picture.Free; Desktop.Free; End;

Вывести номер строки и столбца TStringGrid.

Автор: Дмитрий Карагеур

Вывести список блокировок

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

Code: Select * From. ( --©Drkb v.3(2007): www.drkb.ru. Select convert (smallint, req_spid) As spid, Db_Name(rsc_dbid) As dbName, Object_Name(rsc_objid) As ObjId, Rsc_indid As IndId, Case substring (v.name, 1, 4). When 'FIL' then 'File' When 'DB' then 'Database' When 'IDX' then 'Index' When 'PAG' then 'Page' When 'KEY' then 'Key' When 'TAB' then 'Table' When 'EXT' then 'Extent' When 'RID' then 'Row' Else v.name. End As LockType, Substring (rsc_text, 1, 16) as Resource, Case substring (u.name, 1, 8). When 'S' then 'Shared' When 'U' then 'Update' When 'X' then 'Exclusive' When 'I' then 'Intent' When 'IS' then 'Intent Shared' When 'IX' then 'Intent Exclusive' When 'IU' then 'Intent Update' When 'SIX' then 'shared with intent exclusive' When 'BU' then 'Bulk Update' Else u.name. End As LockMode, Substring (x.name, 1, 5) As Status. From master.dbo.syslockinfo, Master.dbo.spt_values v, Master.dbo.spt_values x, Master.dbo.spt_values u. Where master.dbo.syslockinfo.rsc_type = v.number. And v.type = 'LR' And master.dbo.syslockinfo.req_status = x.number. And x.type = 'LS' And master.dbo.syslockinfo.req_mode + 1 = u.number. And u.type = 'L' ) as t. Where dbName=Db_Name() and ObjId is not NULL. Order By ObjId, LockMode.

©Drkb::02853.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Вывести список активных пользователей

Code: Exec sp_Who.

Code: Exec sp_Who2.

©Drkb::02862.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Выбрать случайные несколько записей.

Выбрать случайные несколько записей

Code: --©Drkb v.3(2007): www.drkb.ru. Select top 10 * From MyTable. Order by NewID().

©Drkb::02793.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Вырезание эллиптической области на Bitmap.

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Вырезание эллиптической области на Bitmap. Овальная рамка для изображения. Зависимости: Classes, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure EllipticBitmap(Bitmap: TBitmap; BackColor: TColor); Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. C: TRGB; X, y: Integer; Dest, Src: pRGB; Bmp: TBitmap; Begin. Bitmap.PixelFormat := pf24Bit; C.R := Lo(BackColor); C.G := Lo(BackColor shr 8); C.B := Lo((BackColor shr 8) shr 8); //создаём дополнительный Bitmap. Bmp := TBitmap.Create; Try. Bmp.Width := Bitmap.Width; Bmp.Height := Bitmap.Height; Bmp.PixelFormat := Bitmap.PixelFormat; //рисуем на созданном Bitmap чёрный эллипс на белом фоне. With Bmp.Canvas do. Begin. Brush.Style := bsSolid; Brush.Color := clWhite; FillRect(Rect(0, 0, Bmp.Width, Bmp.Height)); Brush.Color := clBlack; Pen.Style := psClear; Ellipse(Rect(0, 0, Bmp.Width, Bmp.Height)); End; For y := 0 to Bitmap.Height - 1 do. Begin. Src := Bmp.ScanLine[y]; Dest := Bitmap.ScanLine[y]; For x := 0 to Bitmap.Width - 1 do. Begin. //если точка (x, y) на созданном Bitmap белая, //то точку (x, y) на исходном Bitmap закрашиваем BackColor. If Src^.r = 255 then. Dest^ := C; Inc(Dest); Inc(Src); End; End; Finally. Bmp.Free; End; End; Пример использования: EllipticBitmap(FBitmap, clWhite);

Выделение некоторых узлов другим шрифтом

Code: Uses. CommCtrl; Procedure SetNodeBoldState(Node: TTreeNode; Value: Boolean); Var. TVItem: TTVItem; Begin. If not Assigned(Node) then Exit; With TVItem do. Begin. Mask := TVIF_STATE or TVIF_HANDLE; HItem := Node.ItemId; StateMask := TVIS_BOLD; If Value then state := TVIS_BOLD. Else. State := 0; TreeView_SetItem(Node.Handle, TVItem); End; End; // Example: Make the first node bold. // Beispiel: Erster Eintrag fett machen. Procedure TForm1.Button1Click(Sender: TObject); Begin. SetNodeBoldState(TreeView1.Items[0], True); End;

Выделение подстроки по контексту

Вот 2 функции которыми я очень часто пользуюсь - они выделяют из строки подстроку, которая находится до или после ключевого словаю Задача надо сказать частая, например есть строка:

Выделить подстроку(@result) перед подстрокой(@substr) в строке(@str).

Выделить подстроку(@result) перед подстрокой(@substr) в строке(@str).

Code: --©Drkb v.3(2007): www.drkb.ru. Declare @i int. Declare @result varchar(4000). Set @substr=Replace(@substr, '%', '[%]'). Set @substr=Replace(@substr, '_', '[_]'). Set @i=Patindex('%'+@substr+'%', @str). If @i>0. Set @Result=left(@str,@i-1). Else. Set @Result=@str. Return @Result.

©Drkb::02827.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Выделить строку в Memo.

Code: Procedure TfrmMain.Memo1Click(Sender: TObject); Var. Line: Integer; Begin. With (Sender as TMemo) do. Begin. Line := Perform(EM_LINEFROMCHAR, SelStart, 0); SelStart := Perform(EM_LINEINDEX, Line, 0); SelLength := Length(Lines[Line]); End; End;

Выделять узел TTreeView правой кнопкой мыши

Code: Procedure TForm1.TreeView1ContextPopup(Sender: TObject; MousePos: TPoint; Var Handled: Boolean); Var. TmpNode: TTreeNode; Begin. TmpNode := (Sender as TTreeView).GetNodeAt(MousePos.X, MousePos.Y); If tmpNode <> nil then. TTreeView(Sender).Selected := tmpNode; End;

©Drkb::01112.

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

Выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки.

Выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки

Автор: Nomadic.

Эта функция используется действительно только для отладки. Для того, чтобы результаты ее работы были видны из SQL Plus, необходимо в нем выдать команду:

Set serveroutput on size 10000;

©Drkb::02739.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

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

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. BitmapSrc, BitmapMask: TBitmap; Begin. BitmapSrc := TBitmap.Create; Try. BitmapMask := TBitmap.Create; Try. BitmapSrc.LoadFromFile('c:\src.bmp'); BitmapMask.LoadFromFile('c:\mask.bmp'); MaskBlt(Canvas.Handle, 0, 0, BitmapSrc.Width, BitmapSrc.Height, BitmapSrc.Canvas.Handle, 0, 0, BitmapMask.Handle, 0, 0, MakeROP4(PATCOPY xor PATINVERT, SRCCOPY)); Finally. BitmapMask.Free; End; Finally. BitmapSrc.Free; End; End;

Автор: Rouse_

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

©Drkb::03775.

Вывод строковой информации

Автор: Xavier Pacheco.

Вывод текста на канве картинки

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему?

Вывод текста с использованием Windows API функций

Автор: Олег Грабец

Выбор шрифта

Выбор шрифта

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

Рассмотрим в деталях объект Font и его поля. Объект Font является свойством ячейки или области ячеек Range, а доступ к нему получаем, используя следующий оператор: E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Font, где E = Excel.Application. Объект Font имеет несколько полей, которые влияют на режим отображения символов ячейки. Name - наименование шрифта в формате string. В это поле записывается имя одного из шрифтов, установленного в системе. Bold - параметр, который может принимать значение True или False и который влияет на толщину символов. Italic - принимает значение True (наклонный) или False (прямой) и отвечает за наклонное написание символов. Strikethrough - равен True, если символы перечеркнутые, или False, если не перечеркнутые. Underline - свойство, которое определяет стиль подчеркивания, имеет тип Integer. Когда Underline=xlUnderlineStyleNone, символы отображаются без подчеркивания, если Underline=xlUnderlineStyleSingle, то используется обычное подчеркивание. Когда необходимо использовать дополнительные виды подчеркивания, то применяем определенные константы (смотрите приложение на домашней странице). Color - цвет символов, тип longint.

Нетрудно провести соответствие между описанием полей объекта Font ячеек Excel и объектом Tfont Delphi. Ниже описанная функция использует это соответствие для задания шрифта ячеек таблиц Excel из приложений Delphi. Последним аргументом этой функции является ссылка на объект Font:Tfont, который является стандартным типом объекта Delphi. Этот аргумент мы используем для передачи параметров шрифта в Excel.

Code: Function SetFontRange(sheet:variant;range:string; Font:Tfont):boolean; Begin. SetFontRange:=true; Try. E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Font.Name:=font.Name; If fsBold in font.Style then E.ActiveWorkbook.Sheets.Item. [sheet].Range[range].Font.Bold:=True. Else E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Font.Bold:=False; If fsItalic in font.Style then E.ActiveWorkbook.Sheets.Item. [sheet].Range[range].Font.Italic:=True. Else E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Font.Italic:=False; E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Font.Size:=font.Size; If fsStrikeOut in font.Style. Then E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Font.Strikethrough:=True. Else E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Font.Strikethrough:=False; If fsUnderline in font.Style then. E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Font.Underline:=xlUnderlineStyleSingle. Else E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Font.Underline:=xlUnderlineStyleNone; E.ActiveWorkbook.Sheets.Item [sheet].Range. [range].Font.Color:=font.Color; Except. SetFontRange:=false; End; End;

Выбор и настройка принтера

Выбор и настройка принтера

Если принтеры не установлены, то функции выбора и настройки принтера и задания параметров страницы для печати не могут быть выполнены. Выбор принтера можно осуществить разными способами. Один из них - активизация диалогового окна "Выбор принтера". В Visual Basic это осуществляется оператором Application.Dialogs.Item (xlDialogPrinterSetup).Show, где Dialogs - коллекция диалогов, а xlDialogPrinterSetup - константа, определяющая выбор диалога. В Delphi это можно реализовать в виде функции ShowDialogPrinterSetup, которая возвращает True или False, в зависимости от результата.

Code: Function ShowDialogPrinterSetup:boolean; Const xlDialogPrinterSetup = 9; Begin. ShowDialogPrinterSetup:=true; Try. ShowDialogPrinterSetup:=E.Dialogs.Item. [xlDialogPrinterSetup].Show; Except. ShowDialogPrinterSetup:=false; End; End;

Выбор строки или колонки компонента TStringGrid.

Автор: Neil J. Rubenking.

Вызвать функцию по имени.

Вызвать функцию по имени

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

Code: {©Drkb v.3(2007): www.drkb.ru}. Function TestFunc1(d: Double): Integer; Begin. .... End; Function TestFunc2(d: Double): Integer; Begin. .... End; Exports. TestFunc1, TestFunc2; Procedure TForm1.Button1Click(Sender: TObject); Var. Func: function (d: Double): Integer; Begin. @Func := GetProcAddress(hInstance, PChar(Edit1.Text)); If @Func = nil then. Raise Exception.CreateFmt('Функция с именем "%s" не существует', [Edit1.Text]); ShowMessage(IntToStr(Func(10.63))); End;

Автор: jack128.

©Drkb::00086.

Вызов MapInfo и встраивание его в свою программу

Автор: Дмитрий Кузан

Вычленение подстроки из строки.

Вычленение подстроки из строки

Code: Select Substring('Какая-то строка',7,3).

©Drkb::02823.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Выключить монитор

Code: Procedure TForm1.Button3Click(Sender: TObject); Begin. MessageDlg('Уже поздно. Будь послушным мальчиком. '+ 'Туши свет и вали спать!', mtInformatoion, [mbOk], 0); SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); End; Для того, чтобы программно включить монитор можете использовать следующий код: Procedure TForm1.Button3Click(Sender: TObject); Begin. SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1); End;

Вычисление автокорреляционной функции

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Вычисление автокорреляционной функции. Зависимости: Math. Автор: lookin, lookin@mail.ru, Екатеринбург. Copyright: lookin. Дата: 2 июня 2002 г. ***************************************************** } //TDoubleArray = array of double. Procedure AutoCorrelation(ValueArray: TDoubleArray; var ACArray: TDoubleArray; FromValue, ToValue: integer); Var. I, j, N: integer; Avr, dev, xxsum: double; Begin. //ValueArray - массив типа double для которого вычисляется функция. //FromValue - номер точки, начиная с которого выбираются элементы массива. //ToValue - номер точки, на котором заканчивается выбор элементов массива. //ACArray - массив возвращаемых значений автокорреляционной функции. //для 5-и точек. N := ToValue - FromValue; SetLength(ACArray, 5); If N < 5 then. Begin. For i := 0 to 4 do. ACArray[i] := 0; Exit; End. Else. Begin. SetLength(rv, N); Dev := 0; For i := 0 to N - 1 do. Rv[i] := ValueArray[i + FromValue]; Avr := Mean(rv); For i := 0 to N - 1 do. Dev := dev + Sqr(rv[i] - avr); Dev := dev / N; For j := 0 to 4 do. Begin. Xxsum := 0; For i := 0 to (N - 1) - j do. Xxsum := xxsum + (rv[i] - avr) * (rv[i + j] - avr); ACArray[j] := xxsum / (dev * (N - j)); End; End; End; //Пример использования: Var. SourceArray, ACCoefs: TDoubleArray; Begin. AutoCorrelation(SourceArray, ARCoefs, 0, Length(SourceArray) - 1); For i := 0 to Length(ACCoefs) - 1 do. Showmessage(FloatToStr(ACCoefs[i]));

Вычисление квадратного корня (алгоритм Ньютона).

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление квадратного корня (алгоритм Ньютона). Зависимости: нет. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Автор: Федоровских Николай. Дата: 20 апреля 2003 г. ********************************************** } Function MySqrt(x: Double; n: Byte): Double; { x - аргумент. N - точность вычисления (советую брать 7-8) }. Var i: Integer; Begin. If x <= 0 then begin. Result := 0; Exit; End. Else Result := 4; For i := 0 to n do begin. Result := (Result + x/Result)/2; End; End;

Вычисление логарифма

Code: { --- English ------ A logarithm function with a variable basis. } Function Log(x, b: Real): Real; Begin. Result := ln(x) / ln(b); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage(Format('%f', [Log(10, 10)])); End;

Вычисление наибольшего общего делителя двух целых неотрицательных чисел

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление наибольшего общего делителя двух целых неотрицательных чисел. Зависимости: System. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Turbo Pascal / С.А. Немнюгин. - СПб: Издательство "Питер", 2000. Дата: 27 октября 2002 г. ********************************************** } Function GCD(const m, n: LongWord): LongWord; {Вычисление наибольшего общего делителя. Двух неотрицательных целых чисел. Если какое-то из чисел = 0, то функция возвратит 0. Взято из учебника: Turbo Pascal / С.А. Немнюгин. - СПб: Издательство "Питер", 2000.}. Var p, n1, m1: LongWord; Begin. If (n = 0) or (m = 0) then Result := 0. Else begin. If m < n then begin. N1 := m; M1 := n; End. Else begin. N1 := n; M1 := m; End; While n1 > 0 do begin. P := m1 mod n1; M1 := n1; N1 := p; End; Result := m1; End; End;

Вычисление площади одноконтурного несамопересекающегося многоугольника

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление площади одноконтурного несамопересекающегося многоугольника. 1.Для многоконтурных или самопересекающихся многоугольников функция вернет неверный результат. 2.Площадь всегда положительна (т.е. не зависит от направления обхода). Зависимости: нет. Автор: Виктор Щербаков, shherbakov@yandex.ru, Нижний Новгород. Copyright: Виктор Щербаков. Дата: 18 апреля 2002 г. ********************************************** } // Точка. Type TFloatPoint = record. X, Y: Double; End; // Точки полигона. Type TPolygonPoints = array of TFloatPoint; // Сама функция. Function PolygonSquare(Poly: TPolygonPoints): Double; Var. I, J, HP: Integer; Begin. Result := 0; HP := High(Poly); For I := Low(Poly) to HP do. Begin. If I = HP then J := 0. Else J := I + 1; Result := Result + (Poly[I].X + Poly[J].X) * (Poly[I].Y - Poly[J].Y); End; Result := Abs(Result) / 2; End;

Вычисление определенного интеграла методом трапеций с заданной точностью

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление определенного интеграла методом трапеций с заданной точностью. Просто расчет площади под функцией, параметры: a,b - пределы интегрирования, a<=b. Eps - допустимая погрешность, практически гарантируется, что расхождение результата с истинным значением интеграла не превосходит по модулю указанную величину. Только не переборщите :-)). IntF - подинтегральная функция. Естественно, желательно задавать функции, интегрируемые в смысле Римана. Объявление смотри в примере. Примечание: Несобственные интегралы не считаем :-). Проверок на переполнение нет, да и вообще нет проверок... Зависимости: Ну какие могут быть зависимости? Автор: Romkin, romkin@pochtamt.ru, Москва. Copyright: Romkin 2002. Дата: 19 ноября 2002 г. ********************************************** } Unit intfunc; Interface. Type. TIntFunc = function(X: Double):Double; Function TrapezeInt(a,b:Double; eps: Double; IntF: TIntFunc): Double; Implementation. Function TrapezeInt(a,b:Double; eps: Double; IntF: TIntFunc): Double; Var. //S - площадь на предыдущей итерации, //x - текущее значение аргумента. //base - высота трапеции. //n - число трапеций, удваивается на каждой итерации. S, x, base: Double; I, n: Integer; Begin. //Сначала приближение одной трапецией. Base := b-a; Result := (IntF(a) + IntF(b))/2 * base; Eps := eps / 10; //Вообще говоря, величина делителя зависит от функции. N := 1; Repeat. S := Result; Base := base / 2; N := n * 2; //Новая площадь вычисляется на основе старой. Result := Result / 2; //Ниже - просто вычисляем площади новых трапеций. For i := 1 to n div 2 do. Begin. X := a + base * (i * 2 - 1); Result := Result + IntF(x) * base; End; Until abs(S-Result) <= eps; End; End.

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

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление определенного интеграла методом левых и правых прямоугольников с заданной точностью. "Просто расчет площади под функцией, параметры: a,b - пределы интегрирования, a<=b. Eps - допустимая погрешность, практически гарантируется, что расхождение результата с истинным значением интеграла не превосходит по модулю указанную величину. Только не переборщите :-)). IntF - подинтегральная функция. Естественно, желательно задавать функции, интегрируемые в смысле Римана. Объявление смотри в примере. Примечание: Несобственные интегралы не считаем :-). Проверок на переполнение нет, да и вообще нет проверок...". (Romkin (Москва)). Модуль сделан на основе функции вычисления опред. интеграла методом трапеций от Rоmкin'а (Москва). Зависимости: Нет. Автор: Алексей Глеб, noodlesf@mail.ru, Чернигов. Copyright: с подачи Rоmкin'а (Москва). Дата: 18 мая 2003 г. ********************************************** } Unit IntPram; Interface. Type. TIntFunc=Function(X: Double): Double; Function LeftPramInt(a, b: Double; eps: Double; IntF: TIntFunc): Double; Function RightPramInt(a, b: Double; eps: Double; IntF: TIntFunc): Double; Implementation. Function LeftPramInt(a, b: Double; eps: Double; IntF: TIntFunc): Double; Var. //S - площадь на предыдущей итерации, //step - "толщина" прямоугольника. //gran - передвигаемая от a до b граница. //n - число прямоугольников, удваивается на каждой итерации. S, step, gran: Double; N: integer; Begin. //Сначала приближение одного прямоугольника. Step:=b-a; Result:=IntF(a)*step; N:=1; Repeat. S:=Result; N:=n*2; Step:=(b-a)/n; Gran:=a; Result:=0; //Ниже - просто вычисляем площади новых прямоугольников. While gran<b do. Begin. Result:=Result+IntF(gran)*step; Gran:=gran+step; End; Until abs(S-Result)<=eps; End; Function RightPramInt(a, b: Double; eps: Double; IntF: TIntFunc): Double; Var. //S - площадь на предыдущей итерации, //step - "толщина" прямоугольника. //gran - передвигаемая от a до b граница. //n - число прямоугольников, удваивается на каждой итерации. S, step, gran: Double; N: integer; Begin. //Сначала приближение одного прямоугольника. Step:=b-a; Result:=IntF(b)*step; N:=1; Repeat. S:=Result; N:=n*2; Step:=(b-a)/n; Gran:=b; Result:=0; //Ниже - просто вычисляем площади новых прямоугольников. While a<gran do. Begin. Result:=Result+IntF(gran)*step; Gran:=gran-step; End; Until abs(S-Result)<=eps; End; End.

Вычисление простого хеш-кода для блока данных

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Вычисление простого хеш-кода для блока данных. Вычисляет значение простой хеш-функции (xor + циклический сдвиг) для блока. Данных. Описание параметров: Data - указатель на блок данных. DataSize - размер блока. Возвращаемое значение - значение хеш-функции. Зависимости: нет. Автор: vuk, vuk@fcenter.ru. Copyright: Алексей Вуколов. Дата: 18 апреля 2002 г. ********************************************** } Function CalcHash(Data : pointer; DataSize : integer) : integer; register; Asm. Push ebx. Push esi. Push edi. Mov esi, Data. Xor ebx, ebx. Or esi, esi. Jz @@Exit. Mov edx, DataSize. Or edx,edx. Jz @@Exit. Xor ecx,ecx. @@Cycle: Xor eax,eax. Mov al,[esi]. Inc esi. Rol eax,cl. Xor ebx,eax. Inc ecx. Dec edx. Jnz @@Cycle. @@Exit: Mov eax,ebx. Pop edi. Pop esi. Pop ebx. End;

Выполнение SQL заданного строкой

Code: Declare @sql varchar(8000). --©Drkb v.3(2007): www.drkb.ru. Set @sql='Select * From MyTable' Exec (@sql).

©Drkb::02811.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Выполнить DOS комманду на серверном компьютере

Code: Exec master..xp_cmdshell 'Dir c:\*.*'

©Drkb::02847.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Высота и ширина ячейки Excel.

Высота и ширина ячейки

Чтобы формировать вид документа в процессе его создания, недостаточно только функций записи информации в ячейки, необходимо также изменять ее визуальные параметры. Самое простое, с чего можно начать, - изменение ширины столбцов и высоты строк. Доступ к ширине столбцов можно получить, используя коллекцию Columns. Используя номер колонки в буквенном или числовом формате и свойство коллекции ColumnWidth, можно изменить ширину столбца или назначить ее. Определенная ниже функция, реализованная на Delphi, устанавливает ширину столбца.

Code: Function SetColumnWidth (sheet:variant; Column:variant;width:real):boolean; Begin. SetColumnWidth:=true; Try. E.ActiveWorkbook.Sheets.Item[sheet].Columns. [column].ColumnWidth:=width; Except. SetColumnWidth:=false; End; End;

Быстрая сортировка

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Сортировка различными методами. Сортировка одномерного массива значений типа Double методами: 3) Быстрая сортировка (QuickSort); Зависимости: Math. Автор: iZEN, izen@mail.ru. Copyright: адаптация для Delphi. Дата: 14 сентября 2004 г. ********************************************** } {Сортировка QuickSort}. Procedure QuickSort(var data: array of double); Procedure QSort(var b: array of double; iLo, iHi: Integer); Var. Lo, Hi: Integer; Mid, t: double; Begin. Lo := iLo; Hi := iHi; Mid := b[(Lo + Hi) div 2]; Repeat. While b[Lo] < Mid do Inc(Lo); While b[Hi] > Mid do Dec(Hi); If Lo <= Hi then. Begin. T := b[Lo]; B[Lo] := b[Hi]; B[Hi] := t; Inc(Lo); Dec(Hi); End; Until Lo > Hi; If Hi > iLo then QSort(b, iLo, Hi); If Lo < iHi then QSort(b, Lo, iHi); End; Begin. QSort(data, Low(data), High(data)); End;

©Drkb::04166.

Быстрая функция для разбивки строки на части (слова) в один цикл.

Code: Type TDelim=set of Char; TArrayOfString=Array of String; //******************* // // Разбивает строку с разделителями на части. // и возвращает массив частей. // // fcToParts. // Function fcToParts(sString:String;tdDelim:TDelim):TArrayOfString. Var iCounter,iBegin:Integer; Begin//fc. If length(sString)>0 then. Begin. Include(tdDelim,#0);iBegin:=1; SetLength(Result,0); For iCounter:=1 to Length(sString)+1 do. Begin//for. If (sString[iCounter] in tdDelim) then. Begin. SetLength(Result,Length(Result)+1); Result[Length(Result)-1]:=Copy(sString,iBegin,iCounter-iBegin); IBegin:=iCounter+1; End; End;//for. End;//if. End;//fc.

Быстрое сравнение памяти

Автор: Dennis Passmore.

Быстрые функции сжатия пробелов и управляющих символов в строке

AVL-деревья

Источник: Технология Клиент-Сервер

Бинарные деревья поиска предназначены для быстрого доступа к данным. В идеале разумно сбалансированное дерево имеет высоту порядка O(log2n). Однако при некотором стечении обстоятельств дерево может оказаться вырожденным. Тогда высота его будет O(n), и доступ к данным существенно замедлится. В этом разделе мы рассмотрим модифицированный класс деревьев, обладающих всеми преимуществами бинарных деревьев поиска и никогда не вырождающихся. Они называются сбалансированными или AVL-деревьями. Под сбалансированностью будем понимать то, что для каждого узла дерева высоты обоих его поддеревьев различаются не более чем на 1. Строго говоря, этот критерий нужно называть AVL-сбалансированностью в отличие от идеальной сбалансированности, когда для каждого узла дерева количества узлов в левом и правом поддеревьях различаются не более чем на 1. Здесь мы всегда будем иметь в виду AVL-сбалансированность.

Новые методы вставки и удаления в классе AVL-деревьев гарантируют, что все узлы останутся сбалансированными по высоте. На рисунках 1 и 2 показаны эквивалентные представления массива AVL-деревом и бинарным деревом поиска. Рисунок 1 представляет простой пятиэлементный массив А (A[5] = {1,2,3,4,5}), отсортированный по возрастанию. Рисунок 2 представляет массив B (B[8] = {20, 30, 80, 40, 10, 60, 50, 70}). Бинарное дерево поиска имеет высоту 5, в то время как высота AVL-дерева равна 2. В общем случае высота сбалансированного дерева не превышает O(log2n). Таким образом, AVL-дерево является мощной структурой хранения, обеспечивающей быстрый доступ к данным.

В этом разделе используется упоминавшийся в предыдущей статье подход, при котором поисковое дерево строится отдельно от своих узлов. Сначала мы разработаем класс AVLTreeNode, а затем используем объекты этого типа для конструирования класса AVLTree. Предметом пристального внимания будут методы Insert и Delete. Они требуют тщательного проектирования, поскольку должны гарантировать, что все узлы нового дерева останутся сбалансированными по высоте.

Узлы AVL-дерева

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

Left data balanceFactor right.

AVLTreeNode.

BalanceFactor = height(right subtree) - height(left subtree).

Если balanceFactor отрицателен, то узел «перевешивает влево», так как высота левого поддерева больше, чем высота правого поддерева. При положительном balanceFactor узел «перевешивает вправо». Сбалансированный по высоте узел имеет balanceFactor = 0. В AVL-дереве показатель сбалансированности должен быть в диапазоне [-1, 1].

На рисунке 3 изображены AVL-деревья с пометками -1, 0 и +1 на каждом узле, показывающими относительный размер левого и правого поддеревьев.

· -1: Высота левого поддерева на 1 больше высоты правого поддерева.

· 0: Высоты обоих поддеревьев одинаковы.

· +1: Высота правого поддерева на 1 больше высоты левого поддерева.

Рис. 1.

Рис. 2.

Используя свойства наследования, можно образовать класс AVLTreeNode на базе класса TreeNode. Объект типа AVLTreeNode наследует поля из класса TreeNode и добавляет к ним поле balanceFactor. Данные-члены left и right класса TreeNode являются защищенными, поэтому AVLTreeNode или другие производные классы имеют к ним доступ.

Рис. 3.

Спецификация класса AVLTreeNode

ОБЪЯВЛЕНИЕ

Code: // наследник класса TreeNode. Template < class T > Class AVLTreeNode: public TreeNode < T > { Private: // дополнительный член класса balanceFactor. // используется методами класса AVLTree и позволяет. // избегать "перевешивания" узлов. Int balanceFactor; AVLTreeNode<T>* amp; Left(void); AVLTreeNode<T>* amp; Right(void); Public: // конструктор. AVLTreeNode(const Tamp; item, AVLTreeNode<T> *lptr = NULL, AVLTreeNode<T> *rptr = NULL, int balfac = 0); // возвратить левый/правый указатель узла типа TreeNode, // преобразовав его к типу AVLTreeNode. AVLTreeNode<T> *Left(void) const; AVLTreeNode<T> *Right(void) const; // метод для доступа к новому полю данных. Int GetBalanceFactor(void); // методы класса AVLTree должны иметь доступ к Left и Right. Friend class AVLTree<T>; };

Avoiding server side locking (including DEADLOCK).

What can I do to help avoid server side locking (including DEADLOCK).

Problems when working with Microsoft SQL Server (DBLIB) and Sybase.

SQL Server (DBLIB)?

The following suggestions may help you tune your application and.

Server. The server side suggestions may not apply to all server.

And database installations.

From the client application you may want to take greater control.

Over the size of results sets (this may mean using TQueries),

Minimize the length of transactions (usually not an issue if the.

SQLPASSTHRU MODE is set to ...AUTOCOMMIT), and only open dbaware.

Controls when necessary to help minimize resource drain on the.

Server and, possibly in this case, deadlock potential.

The means by which the BDE selects data from each of the supported.

Servers does not make assumptions about how each server chooses.

To ensure data integrity.

Delphi/BDE suggestions:

Work with smaller result sets (TQueries, server views, etc.).

Also see above form more info.

Check the SQL Links MSSQL Driver "TDS Packet Size" param.

Making sure that it is set to, at least, 4096.

Minimize the length of transactions.

Investigate creating appropriate indexes.

Filter results before opening a dataset or use tqueries.

(live or otherwise) to limit the number of rows selected.

Investigate using the BDE SQL PASSTHRU MODE parameter.

"NOT SHARED" (please see BDEADMIN.HLP and BDE32.HLP for.

Addtional information on the SQL PASSTHRU MODE parameter).

Please note:

BDE/SQL Links 4.01 will not only detect and raise a deadlock.

Error but it will "reset" its database transaction state when.

It detects an MSSQL error 1205. It is not necessary to rollback.

The explicit transaction (Database1.rollback) after the.

Deadlock has been detected.

The error 1205 signals to the client that the server has.

"resolved" a deadlock and chosen one of the users to end the.

Deadlock. This user's transaction is automatically rolled back.

Please refer to the MS SQL Server documentation for more.

Information on deadlock detection and server error 1205.

MS SQL and Sybase Server topics: (the following is by no means a.

Comprehensive list. Please check your Sybase and MS SQL Server.

Docs for tips on optimizing your server and databases).

Create indexes on the remote tables where possible (the.

Server may require more locks for unindexed tables.).

TEXT and IMAGE columns can take up more pages (columns.

Can be omitted from a SELECT statement if working with TQueries.

Whose REQUEST LIVE property is false).

Page sizes on the server can be adjusted to better match.

Expected row sizes (this can help prevent the server from locking.

Adjacent rows.).

The server will create a table lock if the LOCK ESCALATION.

Level is reached (part of sp_configure).

Please also see:

MS SQl Server documentation (printed or Books Online).

If using TQueries:

TABLOCKX.

UPDLOCK.

For more information on the options above:

Analyzing locks Topic.

(also see Database Developer's Companion Errata).

©Drkb::02406.

AWE.

AWE или как выйти за пределы 32 битной адресации.

Расширение адресной облочки Windows.

Описание работы с AWE.

Функции для работы с AWE:

MapUserPhysicalPages.

AllocateUserPhysicalPages.

MapUserPhysicalPagesScatter.

FreeUserPhysicalPages.

© Mystic, 2002.

©Drkb::02039.

В StringGrid ширина колонки подгоняется под длину самой длинной строки

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

Как можно определить Handle окна,над которым находится мышка?

WindowFromPoint.

ChildWindowFromPoint.

Автор ответа: rhf.

©Drkb::02096.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как прочитать пароль, скрытый за звездочками?

Наверно так: хотя классов может быть больше.

Code: Procedure TForm1.Timer1Timer(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var. Wnd : HWND; LpClassName: array [0..$FF] of Char; Begin. Wnd := WindowFromPoint(Mouse.CursorPos); GetClassName (Wnd, lpClassName, $FF); If ((strpas(lpClassName) = 'TEdit') or (strpas(lpClassName) = 'EDIT')) then. PostMessage (Wnd, EM_SETPASSWORDCHAR, 0, 0); End;

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

Code: PostThreadMessage(AnotherProg_MainThreadID,WM_CLOSE,0,0); PostMessage(AnotherProg_MainWindow,WM_CLOSE,0,0);

Пример работы с MailSlot.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. HSlot1 : THandle; LpszSlotName: LPSTR; Begin. LpszSlotName := '\\\\.\\mailslot\\sample_mailslot'; Hslot1 := CreateMailslot (lpszSlotName, 0, MAILSLOT_WAIT_FOREVER, Nil); //тут поидее должна быть обработка ошибки, если не удалось создать. //Далее работаем с ним, как с файлом т.е. WriteFile и т.д. // CloseHandle(hSlot1); //а кады закрываем за собой дескриптор, //то память чистится т.е. все, что мы туда поназаписали удаляется. End;

Как найти скорость процессора?

Пример взят из рассылки: СообЧА. Программирование на Delphi (http://Subscribe.Ru/catalog/comp.soft.prog.delphi2000)

Code: Function GetCPUSpeed: Double; Const DelayTime = 500; Var TimerHi : DWORD; TimerLo : DWORD; PriorityClass : Integer; Priority : Integer; Begin. PriorityClass := GetPriorityClass(GetCurrentProcess); Priority := GetThreadPriority(GetCurrentThread); SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS); SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL); Sleep(10); Asm. DW 310Fh // rdtsc. MOV TimerLo, EAX. MOV TimerHi, EDX. End; Sleep(DelayTime); Asm. DW 310Fh // rdtsc. SUB EAX, TimerLo. SBB EDX, TimerHi. MOV TimerLo, EAX. MOV TimerHi, EDX. End; SetThreadPriority(GetCurrentThread, Priority); SetPriorityClass(GetCurrentProcess, PriorityClass); Result := TimerLo / (1000.0 * DelayTime); End; // Usage ... LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]);

©Drkb::01415.

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: Function GetCPUSpeed: real; Function IsCPUID_Available: Boolean; assembler; register; Asm. PUSHFD { прямой доступ к флагам невозможен, только через стек }. POP EAX { флаги в EAX }. MOV EDX,EAX { сохраняем текущие флаги }. XOR EAX,$200000 { бит ID не нужен }. PUSH EAX { в стек }. POPFD { из стека в флаги, без бита ID }. PUSHFD { возвращаем в стек }. POP EAX { обратно в EAX }. XOR EAX,EDX { проверяем, появился ли бит ID }. JZ @exit { нет, CPUID не доступен }. MOV AL,True { Result=True }. @exit: End; Function hasTSC: Boolean; Var. Features: Longword; Begin. Asm. MOV Features,0 { Features = 0 }. PUSH EBX. XOR EAX,EAX. DW $A20F. POP EBX. CMP EAX,$01. JL @Fail. XOR EAX,EAX. MOV EAX,$01. PUSH EBX. DW $A20F. MOV Features,EDX. POP EBX. @Fail: End; HasTSC := (Features and $10) <> 0; End; Const. DELAY = 500; Var. TimerHi, TimerLo: Integer; PriorityClass, Priority: Integer; Begin. Result := 0; If not (IsCPUID_Available and hasTSC) then Exit; PriorityClass := GetPriorityClass(GetCurrentProcess); Priority := GetThreadPriority(GetCurrentThread); SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS); SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL); SleepEx(10, FALSE); Asm. DB $0F { $0F31 op-code for RDTSC Pentium инструкции }. DB $31 { возвращает 64-битное целое (Integer) }. MOV TimerLo,EAX. MOV TimerHi,EDX. End; SleepEx(DELAY, FALSE); Asm. DB $0F { $0F31 op-code для RDTSC Pentium инструкции }. DB $31 { возвращает 64-битное целое (Integer) }. SUB EAX,TimerLo. SBB EDX,TimerHi. MOV TimerLo,EAX. MOV TimerHi,EDX. End; SetThreadPriority(GetCurrentThread, Priority); SetPriorityClass(GetCurrentProcess, PriorityClass); Result := TimerLo / (1000 * DELAY); End;

©Drkb::01416.

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

Code: Const. ID_BIT=$200000; // EFLAGS ID bit. Function GetCPUSpeed: Double; Const. DelayTime = 500; Var. TimerHi, TimerLo: DWORD; PriorityClass, Priority: Integer; Begin. Try. PriorityClass := GetPriorityClass(GetCurrentProcess); Priority := GetThreadPriority(GetCurrentThread); SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS); SetThreadPriorit(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL); Sleep(10); Asm. Dw 310Fh // rdtsc. Mov TimerLo, eax. Mov TimerHi, edx. End; Sleep(DelayTime); Asm. Dw 310Fh // rdtsc. Sub eax, TimerLo. Sbb edx, TimerHi. Mov TimerLo, eax. Mov TimerHi, edx. End; SetThreadPriority(GetCurrentThread, Priority); SetPriorityClass(GetCurrentProcess, PriorityClass); Result := TimerLo / (1000.0 * DelayTime); Except end; End; Procedure TForm1.Button1Click(Sender: TObject); Var cpuspeed:string; Begin. Cpuspeed:=Format('%f MHz', [GetCPUSpeed]); Edit1.text := cpuspeed; End;

Сохранить строку в памяти?+пример работы с атомами.

Например через атомы:

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

Code: Const UniqueSignature='GI7324hjbHGHJKdhgn90jshUH*hjsjshjdj'; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Procedure CleanAtoms; Var P:PChar; I:Word; Begin. GetMem(p, 256); For i:=0 to $FFFF do. Begin. GlobalGetAtomName(i, p, 255); If StrPos(p, PChar(UniqueSignature))<>nil then GlobalDeleteAtom(i); End; FreeMem(p); End; Procedure WriteAtom(Str:string); Begin. CleanAtoms; GlobalAddAtom(PChar(UniqueSignature+Str)); End; Function ReadAtom:string; Var P:PChar; I:Word; Begin. GetMem(p, 256); For i:=0 to $FFFF do. Begin. GlobalGetAtomName(i, p, 255); If StrPos(p, PChar(UniqueSignature))<>nil then break; End; Result:=StrPas(p+length(UniqueSignature)); FreeMem(p); End; Procedure TReadFromAtom.Button1Click(Sender: TObject); Begin. WriteAtom(Edit1.text); End; Procedure TReadFromAtom.Button2Click(Sender: TObject); Begin. Showmessage(ReadAtom); End;

Что такое порт? Правила для работы с портами.

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml.

Автор Дмитрий Кузан, mailto:kuzan@fsskomi.parma.ru Известно что в компьютере очень много собрано различных устройств , возникает вопрос как операционная система общается с ними. Для этого и служит порт, то есть эта «дверь» через которую программа (операционная система) может управлять данным устройством (считывать данные, заносить их).Причем я разделяю порты на две категории (это чисто мое разделение) - порты общеизвестные (COM LPT) и порты внутренние ,служащие для связи с внутренними устройствами ЭВМ. 2.Некоторые правила для работы с портами Следует иметь в виду что при разработке программ имеющих дело.

Работы с портами следует учитывать следующие факторы :

А) Стараться использовать функции высокого уровня для доступа к портам (в частности WinAPI) и не прибегать к низкоуровневым операциям чтения/записи портов. Если вы все-таки решили писать низкоуровневое чтение то эти процедуры нужно выносить в отдельную DLL или VXD, по следующим причинам - известно, что операционная система Windows95/98 а особенно NT являются по своей сути многозадачными системами. То есть если ваша программа обращается конкретно к порту не через динамический вызов функции DLL или VXD ( использования механизма DLL) а напрямую то это может сказаться на корректной работе системы или даже завалить ее. И даже если в Windows95/98 такой подход вполне может работать то в Windows NT вследствие его архитектуры не разрешит непосредственное чтение/запись напрямую, а использование механизма DLL или VXD позволяет обойти эту проблему.

Б)Если вы работаете с каким-то нестандартным портом ввода-вывода.

(например портом хранящим состояние кнопок пульта ДУ TVTunera то наверняка в комплекте поставки родного софта найдется DLL или VXD для управления этим устройством и отпадет нужда писать код, так я при работе с пультом ДУ ТVТиnега использую стандартную DLL поставляемую в комплекте, это сразу решило вопросы связанные с управлением портами данного тюнера)Итак, отступление — немного практики…

Маленький пример для работы с портами.

(первый пример был уже опубликован в королевстве Дельфи.

И представлял собой пример работы с весами ПетрВес).

Code: 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 := скорость; 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; //закрыть порт. Begin. Result := Windows.CloseHandle(f); End; Function PostComm(var Buf; size: word): integer; //переда?а в порт. 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; //прием из порта. 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) для работы с портами.

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

Code: 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.

Указывает тип доступа к объекту ,принимает значение.

GENERIC_READ - для чтения.

GENERIC_WRITE - для записи (смешивание с GENERIC_READ.

Операцией GENERIC_READ and GENERIC_WRITE предостовляет полный доступ ).

DwShareMode.

Набор разрядных флагов, которые определяют как объект может быть разделен по доступу к нему.

Если dwShareMode - 0, объект не может быть разделен.

Последовательные операции открытия объекта будут терпеть неудачу,

Пока маркер(дескриптор) открытого объекта не будет закрыт.

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

FILE_SHARE_DELETE (Только для Windows NT).

FILE_SHARE_READ.

FILE_SHARE_WRITE.

LpSecurityAttributes.

Указатель на структуру SECURITY_ATTRIBUTES, которая определяет.

Может ли возвращенный дескриптор быть унаследован дочерними процессами.

Если lpSecurityAttributes НУЛЕВОЙ, маркер не может быть унаследован.

Используется только в windows NT.

DwCreationDistribution.

Определяет поведение функции если объект уже существует и.

Как он будет открыт в этом случае Принимает одно из следующих значений :

CREATE_NEW.

Создает новый объект (файл) Выдает ошибку если указанный объект (файл) уже существует.

CREATE_ALWAYS.

Создает новый объект (файл) Функция перезаписывает существующий объект (файл).

OPEN_EXISTING.

Открывает объект (файл) Выдает ошибку если указанный объект (файл) не существует.(Для более детального смотрите SDK).

OPEN_ALWAYS.

Открывает объект (файл), если он существует. Если объект (файл) не существует,

Функция создает его, как будто dwCreationDistribution были CREATE_NEW.

TRUNCATE_EXISTING.

Открывает объект (файл). После этого объект (файл) будет.

Усечен до нулевого размера.Выдает ошибку если указанный объект (файл) не существует.

DwFlagsAndAttributes.

Атрибуты объекта (файла) , атрибуты могут комбинироваться.

FILE_ATTRIBUTE_ARCHIVE.

FILE_ATTRIBUTE_COMPRESSED.

FILE_ATTRIBUTE_HIDDEN.

FILE_ATTRIBUTE_NORMAL.

FILE_ATTRIBUTE_OFFLINE.

FILE_ATTRIBUTE_READONLY.

FILE_ATTRIBUTE_SYSTEM.

FILE_ATTRIBUTE_TEMPORARY.

HTemplateFile.

Определяет дескриптор с GENERIC_READ доступом к временному объекту(файлу).

Временный объект(файл)поставляет атрибуты файла и расширенные атрибуты.

Для создаваемого объекта (файла).

ИСПОЛЬЗУЕТСЯ ТОЛЬКО В WINDOWS NT Windows 95: Это значение должно быть установлено в Nil.

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

К указанному объекту(файлу). Если файл не существует - 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, не.

LpSecurityDescriptor.

Дескриптор указывающий на описатель защиты для объекта,

Если дескриптор ПУСТОЙ объект может быть назначен в наследование дочерними процессами.

BInheritHandle.

Определяет, унаследован ли возвращенный дескриптор, когда новый дескриптор, создан.

Если это значение принимает ИСТИНУ новый дескриптор наследует от головного.

Замечания.

Указатель на структуру SECURITY_ATTRIBUTES используется.

Как параметр в большинстве функций работы с окнами в Win32 API.

---------------------

Структура 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;

Code: 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_1200CBR_57600.

CBR_2400CBR_115200.

CBR_4800CBR_128000.

CBR_9600CBR_256000.

CBR_14400 fBinary.

Определяет, допускается ли двоичный (бинарный) способ передачи данных.

Win32 API не поддерживает недвоичные (небинарные).

Способы передачи данных в потоке порта, так что этот параметр.

Должен быть всегда ИСТИНЕН.

Попытка использовать ЛОЖЬ в этом параметре не будет работать.

Примечание : Под Windows 3.1 небинарный способ передачи допускается,

Но для работы данного способа необходимо заполнит параметр.

EofChar который будет восприниматься конец данных.

FParity.

Определяет, допускается ли проверка четности.

Если этот параметр ИСТИНЕН, проверка четности допускается.

FOutxCtsFlow.

CTS (clear-to-send) управление потоком выхода.

FOutxDsrFlow.

DSR (data-set-ready) управление потоком выхода.

FDtrControl.

DTR (data-terminal-ready) управление потоком выхода.

Принимает следующие значения :

DTR_CONTROL_DISABLE.

Отключает линию передачи дынных.

DTR_CONTROL_ENABLE.

Включает линию передачи дынных.

DTR_CONTROL_HANDSHAKE.

Enables DTR handshaking. If handshaking is enabled,

It is an error for the application to adjust the line by using the EscapeCommFunction function.

Допускает подтверждению связи передачи данных.

Если подтверждение связи допускается, это - погрешность для того чтобы регулировать(корректировать).

Линию связи, используя функцию EscapeCommFunction.

FDsrSensitivity.

Specifies whether the communications driver is sensitive to the state of the DSR signal.

If this member is TRUE, the driver ignores any bytes received, unless the DSR modem input line is high.

Определяет возможна ли по порту двухсторонняя передача в ту и в другую сторону сигнала.

FTXContinueOnXoff.

Определяет, останавливается ли передача потока ,

Когда входной буфер становится полный, и драйвер передает сигнал XoffChar.

Если этот параметр ИСТИНЕН, передача продолжается после того,

Как входной буфер становится в пределах XoffLim байтов, и драйвер передает.

Сигнал XoffChar, чтобы прекратить прием байтов из потока .

Если этот параметр ЛОЖНЫЙ, передача не продолжается до тех пор ,

Пока входной буфер не в пределах XonLim байтов,

И пока не получен сигнал XonChar, для возобновления приема .

FOutX.

Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА.

В течение передачи потока порту. Если этот параметр ИСТИНЕН, передача останавливается,

Когда получен сигнал XoffChar и начинается снова, когда получен сигнал XonChar.

FInX.

Specifies 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.

Определяет, отвергнуты ли нулевые(пустые) байты. Если этот параметр ИСТИНЕН,

Нулевые(пустые) байты, будут отвергнуты при получении их.

FRtsControl.

RTS управление потоком " запрос пересылки " .

Если это значение нулевое, то по умолчанию устанавливается RTS_CONTROL_HANDSHAKE.

Принимает одно из следующих значений:

RTS_CONTROL_DISABLE.

Отключает строку RTS, когда устройство открыто.

RTS_CONTROL_ENABLE.

Включает строку RTS.

RTS_CONTROL_HANDSHAKE.

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.

RTS_CONTROL_TOGGLE.

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 будет низок.

FAbortOnError.

Определяет, закончена ли операции чтения/записи, если происходит погрешность.

Если этот параметр ИСТИНЕН, драйвер закрывает все операции.

Чтения/записи с состоянием погрешности при возникновении оной.

Драйвер не будет принимать никакие дальнейшие действия,

Пока не дождется подтверждения погрешности в передоваемых.

(принимаемых) данных, вызывая функцию ClearCommError.

FDummy2.

ЗАРЕЗЕРВИРОВАНО Microsoft.

WReserved.

ЗАРЕЗЕРВИРОВАНО Microsoft.

XonLim.

Определяет минимальное число байтов, находящихся во в.

XoffLim.

Определяет максимальное число байтов, находящихся во входном буфере прежде,

Чем будет генерирована подача СТОП-СИГНАЛА. Максимальное число байтов,

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

ByteSize.

Определяет число битов в байтах, переданных и полученных.

Parity.

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

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

EVENPARITY.

MARKPARITY.

NOPARITY.

ODDPARITY.

StopBits.

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

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

ONESTOPBIT1 stop bit.

ONE5STOPBITS1.5 stop bits.

TWOSTOPBITS2 stop bits.

XonChar.

Определяет значение СТАРТ-СИГНАЛА для передачи и приема.

XoffChar.

Определяет значение СТОП-СИГНАЛА для передачи и приема.

ErrorChar.

Определяет значение СИГНАЛА ОШИБКИ (генерируемого при ошибке четности) для передачи и приема.

EofChar.

Определяет значение сигнала конца данных.

EvtChar.

Определяет значение сигнала события.

WReserved1.

ЗАРЕЗЕРВИРОВАНО Microsoft.

Дополнение : Когда структура DCB использует «ручной» выбор конфигурации ,

Следующие ограничения используются для ByteSize и StopBits параметров :

Число информационных разрядов должно быть от 5 до 8 битов.

Использование 5 информационных разрядов с 2 стоповыми битами -

Недопустимая комбинация, как - 6, 7, или 8 информационных разрядов с 1.5 стоповыми битами.

©Drkb::01338.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как отличить нажат правый или левый SHIFT?

Code: If ((Word(GetKeyState(VK_LSHIFT)) and $8000) <> 0) then. Begin. End; If ((Word(GetKeyState(VK_RSHIFT)) and $8000) <> 0) then. Begin. End;

Работает под Win NT/2000, но не работает под Win95.

Автор ответа: CHERRY.

©Drkb::01473.

Взято с Vingrad.ru http://forum.vingrad.ru.

В 95 катит следующее:

Code: {©Drkb v.3(2007): www.drkb.ru}. RSHIFT = 36h. LSHIFT = 2Ah. Asm. In al, 60h. Cmp al, 36h. Jne @@exit. Mov tt,1. @@exit: End; If tt = 1 then ShowMessage ('Right Shift');

Автор ответа: Baa.

©Drkb::01474.

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: Procedure TDecEditForm.Memo1KeyPress(Sender: TObject; var Key: Char); VAR s:String; RL:Byte; Begin. IF key=CHR(VK_RETURN) Then. Begin. //WIN NT/2000. If (GetVersion() and $80000000)=0 then. BEGIN. IF ((Word(GetKeyState(VK_LSHIFT)) and $8000)<>0) Then. Begin. End; IF ((Word(GetKeyState(VK_RSHIFT)) and $8000)<>0) Then. Begin. End; End. ELSE. //WIN 9.x. Begin. Asm. Mov ah,2. Int $16. Mov RL,al. End; If 1 = (RL and 1) then // ПРАВЫЙ SHIFT НАЖАТ+ENTER. Begin. End; If 2 = (RL and 2) then // ЛЕВЫЙ SHIFT НАЖАТ+ENTER. Begin. End; End; //WIN 9.x. END; End;

Автор ответа: CHERRY.

©Drkb::01475.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как имитировать нажатие левой кнопки мыши?

Code: Mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0); Application.ProcessMessages; Mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);

Блокировка/Разблокировка CD-ROM.

Вы уж простите, что на сях... сподручней было :\

Исходный код.

Code: // ©Drkb v.3(2007): www.drkb.ru. //заблокировать. Void CMFcDlg::OnBnClickedButton1(). { HANDLE hDevice = CreateFile ("\\\\.\\E:", GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, NULL, NULL); DWORD dwBytesReturned = 0; PREVENT_MEDIA_REMOVAL pmr = {TRUE}; If(!DeviceIoControl (hDevice, IOCTL_STORAGE_MEDIA_REMOVAL, &pmr, sizeof(pmr), NULL, 0, &dwBytesReturned, NULL)) AfxMessageBox ("Door can\'t be locked"); CloseHandle (hDevice); } //разблокировать. Void CMFcDlg::OnBnClickedButton2(). { HANDLE hDevice = CreateFile ("\\\\.\\E:", GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, NULL, NULL); DWORD dwBytesReturned = 0; PREVENT_MEDIA_REMOVAL pmr = {FALSE}; If(!DeviceIoControl (hDevice, IOCTL_STORAGE_MEDIA_REMOVAL, &pmr, sizeof(pmr), NULL, 0, &dwBytesReturned, NULL)) AfxMessageBox ("Door can\'t be unlocked"); CloseHandle (hDevice); }

Работа с System Menu.

Добавить новый пункт меню в системное меню диалога:

Code: AppendMenu(GetSystemMenu(Self.Handle,FALSE),MF_ENABLED,1001,'&Help');

Как послать нажатие кнопки мыши в окно?

WM_LBUTTONDOWN.

WM_RBUTTONDOWN.

©Drkb::01576.

Автор: Song.

Взято с Vingrad.ru http://forum.vingrad.ru.

Я решил проверить точку нажатия мышки таким вот образом:

...

SetForegroundWindow(WindowUO);

Mouse_event(MOUSEEVENTF_MOVE,400,400,0,0);

...

И получилось, что мышка перемещалась не в те координаты(относительно разрешения монитора (800 на 600)) которые я задумал(в не зависимости от местоположения мышки она перемещалась строго по одному направлению на одинаковое расстояние), причем я сделал еще один вариант - dx=100, dy=100, но тогда перемещение мышки произошло в другую сторону(в сторону x=0 y=0 монитора)!

Подскажите плз в чем дело?

Автор ответа: Spawn.

©Drkb::01577.

Взято с Vingrad.ru http://forum.vingrad.ru.

Mouse_event программирует не абсолюьные, а относительные координаты.

Чтобы не думалось, просто сначала установите курсор в нужную позицию - SetCursorPos(), а потом делайте клик - Mouse_event().

©Drkb::01578.

Автор: Song.

Взято с Vingrad.ru http://forum.vingrad.ru.

На форму вынесите компонент TTimer и опишите его единственное событие следующим образом:

Code: Procedure TForm1.Timer1Timer(Sender: TObject); Var. X, y: Integer; Begin. X := random(Screen.Width); Y := random(Screen.Height); Sendmessage(Handle, WM_LBUTTONDOWN, MK_LBUTTON, x + y shl 16); Sendmessage(Handle, WM_LBUTTONUP, MK_LBUTTON, x + y shl 16); End;

Как форматировать диск?

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TUndocSHFormat = class(TForm). Label1: TLabel; Combo1: TComboBox; CmdSHFormat: TButton; CmdEnd: TButton; LbMessage: TLabel; Procedure FormCreate(Sender: TObject); Procedure cmdSHFormatClick(Sender: TObject); Procedure cmdEndClick(Sender: TObject); Private. Procedure LoadAvailableDrives; Public. End; Var. UndocSHFormat: TUndocSHFormat; Implementation. {$R *.DFM}. Type POSVERSIONINFO = ^TOSVERSIONINFO; TOSVERSIONINFO = record. DwOSVersionInfoSize: Longint; DwMajorVersion: Longint; DwMinorVersion: Longint; DwBuildNumber: Longint; DwPlatformId: Longint; SzCSDVersion: PChar; End; Function GetVersionEx(lpVersionInformation: POSVERSIONINFO): Longint; stdcall; external 'kernel32.dll' name 'GetVersionExA'; Const VER_PLATFORM_WIN32s = 0; Const VER_PLATFORM_WIN32_WINDOWS = 1; Const VER_PLATFORM_WIN32_NT = 2; Function SHFormatDrive(hwndOwner: longint; iDrive: Longint; iCapacity: LongInt; IFormatType: LongInt): Longint; Stdcall; external 'shell32.dll'; Const SHFD_CAPACITY_DEFAULT = 0; Const SHFD_CAPACITY_360 = 3; Const SHFD_CAPACITY_720 = 5; //Win95. //Const SHFD_FORMAT_QUICK = 0; //Const SHFD_FORMAT_FULL = 1; //Const SHFD_FORMAT_SYSONLY = 2; //WinNT. //Public Const SHFD_FORMAT_FULL = 0. //Public Const SHFD_FORMAT_QUICK = 1. Const SHFD_FORMAT_QUICK: LongInt = 0; Const SHFD_FORMAT_FULL: LongInt = 1; Const SHFD_FORMAT_SYSONLY: LongInt = 2; Function GetLogicalDriveStrings(nBufferLength: LongInt; lpBuffer: PChar): LongInt; Stdcall; external 'kernel32.dll' name 'GetLogicalDriveStringsA'; Function GetDriveType(nDrive: PChar): LongInt; Stdcall; external 'kernel32.dll' name 'GetDriveTypeA'; Const DRIVE_REMOVABLE = 2; Const DRIVE_FIXED = 3; Const DRIVE_REMOTE = 4; Const DRIVE_CDROM = 5; Const DRIVE_RAMDISK = 6; Function IsWinNT: Boolean; Var osvi: TOSVERSIONINFO; Begin. Osvi.dwOSVersionInfoSize := SizeOf(osvi); GetVersionEx(@osvi); IsWinNT := (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT); End; Function GetDriveDisplayString(currDrive: PChar): pchar; Begin. GetDriveDisplayString := nil; Case GetDriveType(currDrive) of. 0, 1: GetDriveDisplayString := ' - Undetermined Drive Type -'; DRIVE_REMOVABLE: Case currDrive[1] of. 'A', 'B': GetDriveDisplayString := 'Floppy drive'; Else. GetDriveDisplayString := 'Removable drive'; End; DRIVE_FIXED: GetDriveDisplayString := 'Fixed (Hard) drive'; DRIVE_REMOTE: GetDriveDisplayString := 'Remote drive'; DRIVE_CDROM: GetDriveDisplayString := 'CD ROM'; DRIVE_RAMDISK: GetDriveDisplayString := 'Ram disk'; End; End; Procedure TUndocSHFormat.LoadAvailableDrives; Var. A, r: LongInt; LpBuffer: array[0..256] of char; CurrDrive: array[0..256] of char; LpDrives: pchar; Begin. Getmem(lpDrives, 256); Fillchar(lpBuffer, 64, #32); R := GetLogicalDriveStrings(255, lpBuffer); If r <> 0 then. Begin. Strlcopy(lpBuffer, lpBuffer, r); For a := 0 to r do. LpDrives[a] := lpBuffer[a]; LpBuffer[r + 1] := #0; Repeat. Strlcopy(currDrive, lpDrives, 3); LpDrives := @lpDrives[4]; Combo1.Items.Add(strpas(currDrive) + ' ' + GetDriveDisplayString(currDrive)); Until lpDrives[0] = #0; End; End; Procedure TUndocSHFormat.FormCreate(Sender: TObject); Begin. LbMessage.caption := ''; LoadAvailableDrives; Combo1.ItemIndex := 0; If IsWinNT then. Begin. SHFD_FORMAT_FULL := 0; SHFD_FORMAT_QUICK := 1; End. Else //it's Win95. Begin. SHFD_FORMAT_QUICK := 0; SHFD_FORMAT_FULL := 1; SHFD_FORMAT_SYSONLY := 2; End; End; Procedure TUndocSHFormat.cmdSHFormatClick(Sender: TObject); Var. Resp: Integer; DrvToFormat: Integer; Prompt: string; Begin. DrvToFormat := Combo1.ItemIndex; Prompt := 'Are you sure you want to run the Format dialog against ' + Combo1.Text; If drvToFormat > 0 then. Resp := MessageDLG(prompt, mtConfirmation, [mbYes, mbNo], 0). Else. Resp := mrYes; If resp = mrYes then. Begin. LbMessage.Caption := 'Checking drive for disk...'; Application.ProcessMessages; SHFormatDrive(handle, drvToFormat, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK); LbMessage.caption := ''; End; End; Procedure TUndocSHFormat.cmdEndClick(Sender: TObject); Begin. Close; End; End.

Автор ответа: Baa.

©Drkb::01375.

Взято с Vingrad.ru http://forum.vingrad.ru.

Сохранение всего содержимого буфера обмена в файл.

Из рассылки "Мастера DELPHI. Новости мира компонент,...".

Code: Var FS:TFileStream; Procedure TForm1.bClearClick(Sender: TObject); Begin. OpenClipBoard(0); EmptyClipboard; CloseClipBoard; End; Procedure TForm1.BSaveClick(Sender: TObject); Var CBF:Cardinal; CBFList:TList; I:Integer; H:THandle; P:Pointer; CBBlockLength,Temp:Cardinal; FS:TFileStream; Begin. If OpenClipBoard(0)then begin. CBFList:=TList.Create; CBF:=0; Repeat. CBF:=EnumClipboardFormats(CBF); If CBF<>0 then. CBFList.Add(pointer(CBF)); Until CBF=0; Edit1.text:=IntToStr(CBFList.Count); If CBFList.Count>0 then begin. FS:=TFileStream.Create('e:\cp.dat',fmCreate); Temp:=CBFList.Count; FS.Write(Temp,SizeOf(Integer)); For i:=0 to CBFList.Count-1 do begin. H:=GetClipboardData(Cardinal(CBFList[i])); If h>0 then begin. CBBlockLength:=GlobalSize(h); If h>0 then begin. P:=GlobalLock(h); If p <> nil then begin. Temp:=Cardinal(CBFList[i]); FS.Write(Temp,SizeOf(Cardinal)); FS.Write(CBBlockLength,SizeOf(Cardinal)); FS.Write(p^,CBBlockLength); End; GlobalUnlock(h); End; End; End; FS.Free; End; CBFList.Free; CloseClipBoard; End; End; Procedure TForm1.bLoadClick(Sender: TObject); Var h:THandle; P:Pointer; CBF:Cardin! Al; CBBlockLength:Cardinal; I,CBCount:Integer; FS:TFileStream; Begin. If OpenClipBoard(0)then begin. FS:=TFileStream.Create('e:\cp.dat',fmOpenRead); If FS.Size=0 then Exit; FS.Read(CBCount,sizeOf(Integer)); If CBCount=0 then Exit; For i:=1 to CBCount do begin. FS.Read(CBF,SizeOf(Cardinal)); FS.Read(CBBlockLength,SizeOf(Cardinal)); H:=GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT,CBBlockLength); If h>0 then begin. P:=GlobalLock(h); If p=nil then. GlobalFree(h). Else begin. FS.Read(p^,CBBlockLength); GlobalUnlock(h); SetClipboardData(CBF,h); End; End; End; FS.Free; CloseClipBoard; End; End;

Как определить откуда был запущен процесс?

Есть handle запущенного PE файла. Как определить откуда он был запущен?

Я так предполагаю что getmodulefilename как и GetModuleHandle.

Работает в рамках только своего процесса.

А решить твою задачу .. можно так:

Тут парочка моих любимых функций.

Code: Uses. Tlhelp32; Type. TModuleArray = array of TModuleEntry32; // Возвращает список описаний (TModuleEntry32) модулей по идентификатору процесса. Function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray; Implementation. Function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray; Var. HSnapshot : THandle; Lpme : TModuleEntry32; Procedure AddModuleToList; Begin. SetLength(Result,High(Result)+2); Result[high(Result)]:=lpme; End; Begin. SetLength(Result,0); HSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,ProcessId); If hSnapshot=-1 then RaiseLastWin32Error; Lpme.dwSize:=SizeOf(lpme); If Module32First(hSnapshot,lpme) then. Begin. AddModuleToList; While Module32Next(hSnapshot,lpme) do AddModuleToList; End; End;

Как запустить и подождать завершения 2х процессов?

Code: Procedure HzChe; Var. HProcess : array [0..1] of Cardinal; Struc1 : PSTARTUPINFO; Struc2 : PROCESS_INFORMATION; Begin. If not CreateProcess ( PChar('c:\PSTOLD.EXE') , Nil, Nil, Nil, False, NORMAL_PRIORITY_CLASS, Nil, Nil, Struc1^, Struc2 ) then ShowMessage ( 'Zhopa kakaya-to'); HProcess[0] := struc2.hProcess; If not CreateProcess ( PChar('c:\PSTOLD1.EXE') , Nil, Nil, Nil, False, NORMAL_PRIORITY_CLASS, Nil, Nil, Struc1^, Struc2 ) then ShowMessage ( 'Zhopa kakaya-to'); HProcess[1] := struc2.hProcess; If WaitForMultipleObjects ( 2, @hProcess, True, INFINITE ) = 1 then. ShowMessage (' vce, priehali' ); End;

Как узнать конфигурацию железа?

Вот компонент для этого нашел:

Http://delphi.mastak.ru/cgi-bin/download.pl?get=1020812496&n=0.

Описание от авторов:

File: msi.zip.

Product: MiTeC System Information Component.

Version: 6.2.

Author: MichaL MutL.

E-Mail: michal.mutl@atlas.cz.

Target: Delphi 5.x, Delphi 6.x.

Platform: W95, W98, NT, W2000, Windows ME, Windows XP.

Status: Fully Functional.

Source: Included.

Description: Component providing detailed system information.

+ Registered organization, owner.

+ Time Zone info.

+ Machine name, IP address, MAC Address.

+ Last boot date and time, Boot time.

+ CPU architecture, type, active mask, count, level, revision, vendor, id, speed,

+ OS version, build number, platform, CSD version, version name, user name, serial number.

+ DVD Region, folders.

+ Graphic adapter chip name, dac, memory, screen width and height, color depth, modes.

+ Sound card name, WaveIn, WaveOut, MIDIIn, MIDIOut, AUX, Mixer device name.

+ Printers.

+ Memory info, allocation granularity, min.and max.application address.

+ Disk info, file system, controllers.

+ BIOS name, copyright, extended info, date.

+ Video BIOS version and date.

+ Network adapter, protocols, sevices, clients,

+ Winsock info.

+ BDE, ODBC, DAO, ADO version.

+ DirectX info.

+ Device overview (like Device Manager).

+ Win9x resources.

+ Running process enumeration.

+ Installed software enumeration.

+ Startup runs enumeration.

+ Performance Library interface (NT & 9x).

+ Internet settings.

+ Sharepoints enumeration.

+ Component showing CPU usage.

©Drkb::01328.

Взято с Vingrad.ru http://forum.vingrad.ru.

Почти все о железе можно прочитать из регистра по HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\

Автор ответа: Diamond cat.

©Drkb::01329.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как получить информацию о процессоре?

О процессоре можно на любом уровне (приложении или драйвере) получить информацию с помощью команды(машинной) CPUID(386+):

Например(Вставка на асм в языке Паскаль):

Code: {Получить тип процессора}. {©Drkb v.3(2007): www.drkb.ru}. Asm. Mov eax,0. Cpuid {Или db 0Fh, 0A2h}. {Теперь регистры EBX:ECX:EDX содержат строку "Genu-inel-ntel" (например)}. End;

Передать в Паскаль содержимое регистров можно, например, так:

Code: Var. EBXstr,ECXstr,EDXstr: string[5]; {©Drkb v.3(2007): www.drkb.ru}. Begin. Asm. Mov eax,0. Cpuid. Mov dword ptr EBXstr+1,EBX. Mov byte ptr EBXstr,4. Mov dword ptr ECXstr+1,ECX. Mov byte ptr ECXstr,4. Mov dword ptr EDXstr+1,EDX. Mov byte ptr EDXstr,4. End; Writeln(EBSstr,ECXstr,EDXstr);

Автор ответа: Chingachguk.

©Drkb::01421.

Code: Unit CpuId; Interface. Uses Windows, Mmsystem, Sysutils, Math, Dialogs; Type. TCpuRec=record. Name:string[128]; Vendor:string[12]; Frequency:word; Family:integer; Model:integer; Stepping:integer; L1DCache:word; L1ICache:word; L2Cache:word; End; TCpuType = (cpu8086, cpu286, cpu386, cpu486, cpuPentium); TCpuData=object. Function GetCPUIDSupport:Boolean; Function GetVendorString:string; Function GetCPUFrequency:word; Procedure GetFMS(var Family,Model,Stepping:byte); Function GetMaxCpuId:dword; Function CheckFPU:Boolean; Function CheckTSC:Boolean; Function CheckMSR:Boolean; Function CheckMPS:Boolean; Function GetNoCpus:cardinal; Function CheckPN:Boolean; Function CheckCMPXCHG8B:Boolean; Function CheckCMOVe:Boolean; Function CheckSelfSnoop:Boolean; Function CheckDebugTraceStore:Boolean; Function CheckFXSAVEFXRSTOR:Boolean; Function CheckMMX:Boolean; Function CheckMMXplus:Boolean; Function CheckSSE:Boolean; Function CheckSSE2:Boolean; Function CheckAMD3DNow:Boolean; Function CheckAMD3DNowPlus:Boolean; Function GetMaxExtendedFunctions:dword; Procedure GetExtendedFMS(var Family,Model,Stepping:byte); Function GetExtendedCpuName:string; Function GetExtendedL1DCache:word; Function GetExtendedL1ICache:word; Function GetExtendedL2Cache:word; Function CheckCeleron:Boolean; Function CheckPentiumIII:Boolean; Function CheckXeon:Boolean; Function CheckPentium4:Boolean; Function CheckIthanium:Boolean; //****Aici am conrectat**** Function IntelP5N:string; Function IntelP6N:string; //****Pana aici**** Function AMDK5N:string; Function Cyrix686N:string; Function GenericCpuN:string; Function P5CacheL1DI:word; Function P6CacheL1DI:word; Function P6CacheL2:word; Function AuthenticAMD:TCpuRec; Function GenuineIntel:TCpuRec; Function CyrixInstead:TCpuRec; Function GenericCPU:TCpuRec; End; Const. Intel486:array[0..8] of string= (''Intel 486 DX'', ''Intel 486 DX'', ''Intel 486 SX'', ''Intel 486 DX2'', ''Intel 486 SL'', ''Intel 486 SX2'', ''Intel 486 DX2'', ''Intel 486 DX4'', ''Intel 486 DX4''); UMC486:array[0..1] of string= (''UMC U5D'', ''UMC U5S''); AMD486:array[0..5] of string= (''AMD 486 DX2'', ''AMD 486 DX2'', ''AMD 486 DX4'', ''AMD 486 DX4'', ''AMD 5x86'', ''AMD 5x86''); IntelP5:array[0..6] of string= (''Intel Pentium P5 A-Step'', ''Intel Pentium P5'', ''Intel Pentium P54C'', ''Intel Pentium P24T Overdrive'', ''Intel Pentium MMX P55C'', ''Intel Pentium P54C'', ''Intel Pentium MMX P55C''); NexGenNx586=''NexGen Nx586''; Cyrix4x86=''VIA Cyrix 4x86''; Cyrix5x86=''VIA Cyrix 5x86''; CyrixMediaGX=''VIA Cyrix Media GX''; CyrixM1=''VIA Cyrix 6x86''; CyrixM2=''VIA Cyrix 6x86MX''; CyrixIII=''VIA Cyrix III''; AMDK5:array[0..3] of string= (''AMD SSA5 (PR75/PR90/PR100)'', ''AMD 5k86 (PR120/PR133)'', ''AMD 5k86 (PR166)'', ''AMD 5k86 (PR200)''); AMDK6:array[0..4] of string= (''AMD K6 (166~233)'', ''AMD K6 (266~300)'', ''AMD K6-2'', ''AMD K6-III'', ''AMD K6-2+ or K6-III+''); Centaur:array[0..2] of string= (''Centaur C6'', ''Centaur C2'', ''Centaur C3''); Rise:array[0..1] of string= (''Rise mP6'', ''Rise mP6''); IntelP6:array[0..7] of string= (''Intel Pentium Pro A-Step'', ''Intel Pentium Pro'', ''Intel Pentium II'', ''Intel Pentium II'', ''Intel Pentium II'', ''Intel Pentium III'', ''Intel Pentium III'', ''Intel Pentium III''); AMDK7:array[0..3] of string= (''AMD Athlon(tm) Processor'', ''AMD Athlon(tm) Processor'', ''AMD Duron(tm) Processor'', ''AMD Thunderbird Processor''); IntelP4=''Intel Pentium 4''; Var CpuData:TCpuData; Implementation. Function TCpuData.GetCPUIDSupport:Boolean; Var TempDetect:dword; Begin. Asm. Pushf. Pushfd. Push eax. Push ebx. Push ecx. Push edx. Pushfd. Pop eax. Mov ebx,eax. Xor eax,$00200000. Push eax. Popfd. Pushfd. Pop eax. Push ebx. Popfd. Xor eax,ebx. Mov TempDetect,eax. Pop edx. Pop ecx. Pop ebx. Pop eax. Popfd. Popf. End; GetCPUIDSupport:=(TempDetect=$00200000); End; Function TCpuData.GetVendorString:string; Var s1,s2,s3:array[0..3] of char; TempVendor:string; I:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,0. Db $0F,$A2 /// cpuid. Mov s1,ebx. Mov s2,edx. Mov s3,ecx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; TempVendor:=''''; For i:=0 to 3 do. TempVendor:=TempVendor+s1[i]; For i:=0 to 3 do. TempVendor:=TempVendor+s2[i]; For i:=0 to 3 do. TempVendor:=TempVendor+s3[i]; GetVendorString:=TempVendor; End; Function TCpuData.GetCPUFrequency:word; Var TimeStart:integer; TimeStop:integer; StartTicks:dword; EndTicks:dword; TotalTicks:dword; CpuSpeed:dword; NeverExit:Boolean; Begin. TimeStart:=0; TimeStop:=0; StartTicks:=0; EndTicks:=0; TotalTicks:=0; CpuSpeed:=0; NeverExit:=True; TimeStart:=timeGetTime; While NeverExit do. Begin. TimeStop:=timeGetTime; If ((TimeStop-TimeStart)>1) then. Begin. Asm. Xor eax,eax. Xor ebx,ebx. Xor ecx,ecx. Xor edx,edx. Db $0F,$A2 /// cpuid. Db $0F,$31 /// rdtsc. Mov StartTicks,eax. End; Break; End; End; TimeStart:=TimeStop; While NeverExit do. Begin. TimeStop:=timeGetTime; If ((TimeStop-TimeStart)>1000) then. Begin. Asm. Xor eax,eax. Xor ebx,ebx. Xor ecx,ecx. Xor edx,edx. Db $0F,$A2 /// cpuid. Db $0F,$31 /// rdtsc. Mov EndTicks,eax. End; Break; End; End; TotalTicks:=EndTicks-StartTicks; CpuSpeed:=TotalTicks div 1000000; GetCPUFrequency:=cpuSpeed; End; Procedure TCpuData.GetFMS(var Family,Model,Stepping:byte); Var TempFlags:dword; BinFlags:array[0..31] of byte; I,pos:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Mov TempFlags,eax. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinFlags[i]:=TempFlags mod 2; TempFlags:=TempFlags div 2; End; Family:=0; Model:=0; Stepping:=0; Pos:=0; For i:=0 to 3 do. Begin. Stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; Pos:=4; For i:=0 to 3 do. Begin. Model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; Pos:=8; For i:=0 to 3 do. Begin. Family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; End; Function TCpuData.GetMaxCpuId:dword; Var TempMax:dword; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,0. Db $0F,$A2 /// cpuid. Mov TempMax,eax. Pop edx. Pop ecx. Pop ebx. Pop eax. End; GetMaxCpuId:=TempMax; End; Function TCpuData.CheckFPU:Boolean; Label NoFpu; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$1. Jz NoFpu. Mov edx,0. Mov TempCheck,edx. NoFpu: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckFpu:=(TempCheck=0); End; Function TCpuData.CheckTSC:Boolean; Label NoTSC; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$10. Jz NoTSC. Mov edx,0. Mov TempCheck,edx. NoTSC: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckTSC:=(TempCheck=0); End; Function TCpuData.CheckMSR:Boolean; Label NoMSR; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$20. Jz NoMSR. Mov edx,0. Mov TempCheck,edx. NoMSR: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckMSR:=(TempCheck=0); End; Function TCpuData.CheckMPS:Boolean; Var SysInfo:TSystemInfo; Begin. GetSysTemInfo(SysInfo); CheckMPS:=(SysInfo.dwNumberOfProcessors>1); End; Function TCpuData.GetNoCpus:cardinal; Var SysInfo:TSystemInfo; Begin. GetSystemInfo(SysInfo); GetNoCpus:=SysInfo.dwNumberOfProcessors; End; Function TCpuData.CheckPN:Boolean; Label NoPN; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$40000. Jz NoPN. Mov edx,0. Mov TempCheck,edx. NoPN: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckPN:=(TempCheck=0); End; Function TCpuData.CheckCMPXCHG8B:Boolean; Label NoCMPXCHG8B; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$100. Jz NoCMPXCHG8B. Mov edx,0. Mov TempCheck,edx. NoCMPXCHG8B: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckCMPXCHG8B:=(TempCheck=0); End; Function TCpuData.CheckCMOVe:Boolean; Label NoCMOVe; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$8000. Jz NoCMOVe. Mov edx,0. Mov TempCheck,edx. NoCMOVe: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckCMOVe:=(TempCheck=0); End; Function TCpuData.CheckSelfSnoop:Boolean; Label NoSelfSnoop; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$8000000. Jz NoSelfSnoop. Mov edx,0. Mov TempCheck,edx. NoSelfSnoop: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckSelfSnoop:=(TempCheck=0); End; Function TCpuData.CheckDebugTraceStore:Boolean; Label NoDebugTraceStore; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$200000. Jz NoDebugTraceStore. Mov edx,0. Mov TempCheck,edx. NoDebugTraceStore: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckDebugTraceStore:=(TempCheck=0); End; Function TCpuData.CheckFXSAVEFXRSTOR:Boolean; Label NoFXSAVEFXRSTOR; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$1000000. Jz NoFXSAVEFXRSTOR. Mov edx,0. Mov TempCheck,edx. NoFXSAVEFXRSTOR: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckFXSAVEFXRSTOR:=(TempCheck=0); End; Function TCpuData.CheckMMX:Boolean; Label NoMMX; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$800000. Jz NoMMX. Mov edx,0. Mov TempCheck,edx. NoMMX: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckMMX:=(TempCheck=0); End; Function TCpuData.CheckMMXplus:Boolean; Label NoMMXplus; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000001. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Test edx,$400000. Jz NoMMXplus. Mov edx,0. Mov TempCheck,edx. NoMMXplus: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckMMXplus:=(TempCheck=0); End; Function TCpuData.CheckSSE:Boolean; Label NoSSE; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$2000000. Jz NoSSE. Mov edx,0. Mov TempCheck,edx. NoSSE: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckSSE:=(TempCheck=0); End; Function TCpuData.CheckSSE2:Boolean; Label NoSSE2; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Test edx,$4000000. Jz NoSSE2. Mov edx,0. Mov TempCheck,edx. NoSSE2: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckSSE2:=(TempCheck=0); End; Function TCpuData.CheckAMD3DNow:Boolean; Label NoAMD3DNow; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000001. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Test edx,$80000000. Jz NoAMD3DNow. Mov edx,0. Mov TempCheck,edx. NoAMD3DNow: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckAMD3DNow:=(TempCheck=0); End; Function TCpuData.CheckAMD3DNowPlus:Boolean; Label NoAMD3DNowPlus; Var TempCheck:dword; Begin. TempCheck:=1; Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000001. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Test edx,$40000000. Jz NoAMD3DNowPlus. Mov edx,0. Mov TempCheck,edx. NoAMD3DNowPlus: Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckAMD3DNowPlus:=(TempCheck=0); End; Function TCpuData.GetMaxExtendedFunctions:dword; Var TempExt:dword; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000000. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Shl eax,1. Shr eax,1. Mov TempExt,eax. Pop edx. Pop ecx. Pop ebx. Pop eax. End; GetMaxExtendedFunctions:=TempExt; End; Procedure TCpuData.GetExtendedFMS(var family,model,stepping:byte); Var TempFlags:dword; BinFlags:array[0..31] of byte; I,pos:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000001. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov TempFlags,eax. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinFlags[i]:=TempFlags mod 2; TempFlags:=TempFlags div 2; End; Family:=0; Model:=0; Stepping:=0; Pos:=0; For i:=0 to 3 do. Begin. Stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; Pos:=4; For i:=0 to 3 do. Begin. Model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; Pos:=8; For i:=0 to 3 do. Begin. Family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i)))); Inc(pos); End; End; Function TCpuData.GetExtendedCpuName:string; Var s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12:array[0..3] of char; TempCpuName:string; I:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000002. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov s1,eax. Mov s2,ebx. Mov s3,ecx. Mov s4,edx. Mov eax,$80000003. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov s5,eax. Mov s6,ebx. Mov s7,ecx. Mov s8,edx. Mov eax,$80000004. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov s9,eax. Mov s10,ebx. Mov s11,ecx. Mov s12,edx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; TempCpuName:=''''; For i:=0 to 3 do. TempCpuName:=TempCpuName+s1[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s2[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s3[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s4[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s5[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s6[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s7[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s8[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s9[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s10[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s11[i]; For i:=0 to 3 do. TempCpuName:=TempCpuName+s12[i]; GetExtendedCpuName:=TempCpuName; End; Function TCpuData.GetExtendedL1DCache:word; Var L1D,TempL1D:dword; BinArray:array[0..31] of byte; I,p:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000005. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov L1D,ecx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinArray[i]:=L1D mod 2; L1D:=L1D div 2; End; TempL1D:=0; P:=0; For i:=24 to 31 do. Begin. TempL1D:=TempL1D+(BinArray[i]*StrToInt(FloatToStr(Power(2,p)))); Inc(p); End; GetExtendedL1DCache:=TempL1D; End; Function TCpuData.GetExtendedL1ICache:word; Var L1I,TempL1I:dword; BinArray:array[0..31] of byte; I,p:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000005. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov L1I,edx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinArray[i]:=L1I mod 2; L1I:=L1I div 2; End; TempL1I:=0; P:=0; For i:=24 to 31 do. Begin. TempL1I:=TempL1I+(BinArray[i]*StrToInt(FloatToStr(Power(2,p)))); Inc(p); End; GetExtendedL1ICache:=TempL1I; End; Function TCpuData.GetExtendedL2Cache:word; Var L2,TempL2:dword; BinArray:array[0..31] of byte; I,p:integer; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,$80000006. Mov ebx,0. Mov ecx,0. Mov edx,0. Db $0F,$A2 /// cpuid. Mov L2,ecx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinArray[i]:=L2 mod 2; L2:=L2 div 2; End; TempL2:=0; P:=0; For i:=16 to 31 do. Begin. TempL2:=TempL2+(BinArray[i]*StrToInt(FloatToStr(Power(2,p)))); Inc(p); End; GetExtendedL2Cache:=TempL2; End; Function TCpuData.CheckCeleron:Boolean; Var BId:byte; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Mov BId,bl. Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckCeleron:=(BId=$1); End; Function TCpuData.CheckPentiumIII:Boolean; Var BId:byte; Begin. CheckPentiumIII:=(CheckMMX and CheckSSE); End; Function TCpuData.CheckXeon:Boolean; Var BId:byte; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Mov BId,bl. Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckXeon:=(BId=$3); End; Function TCpuData.CheckPentium4:Boolean; Var BId:byte; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Mov BId,bl. Pop edx. Pop ecx. Pop ebx. Pop eax. End; CheckPentium4:=(BId=$8); End; Function TCpuData.CheckIthanium:Boolean; Var res:dword; BinArray:array[0..31] of byte; I:byte; Begin. Asm. Push eax. Push ebx. Push ecx. Push edx. Mov eax,1. Db $0F,$A2 /// cpuid. Mov res,edx. Pop edx. Pop ecx. Pop ebx. Pop eax. End; For i:=0 to 31 do. Begin. BinArray[i]:=res mod 2; Res:=res div 2; End; CheckIthanium:=(CheckPentium4 and (BinArray[30]=1)); End; Function TCpuData.IntelP5N:string; Begin. If CheckMMX then IntelP5N:=''Intel Pentium(r) MMX(tm)'' Else IntelP5N:=''Intel Pentium(r)''; End; Function TCpuData.IntelP6N:string; Begin. If CheckCeleron then IntelP6N:=''Intel Celeron(r)'' Else. If CheckPentiumIII then IntelP6N:=''Intel Pentium(r) III'' Else. If CheckXeon then IntelP6N:=''Intel Pentium(r) III Xeon(tm)'' Else. If not CheckMMX then IntelP6N:=''Intel Pentium(r) PRO'' Else IntelP6N:=''Intel Pentium(r) II''; End; Function TCpuData.AMDK5N:string; Var Family,Model,Stepping:byte; Begin. GetFMS(Family,Model,Stepping); If Model=0 then AMDK5N:=''AMD K5'' Else AMDK5N:=GetExtendedCpuName; End; Function TCpuData.Cyrix686N:string; Begin. If CpuData.GetMaxExtendedFunctions>0 then Cyrix686N:=GetExtendedCpuName. Else. If CheckMMX then Cyrix686N:=''VIA Cyrix 6x86MII'' Else. Cyrix686N:=''VIA Cyrix 6x86''; End; Function TCpuData.GenericCpuN:string; Var SysInfo:TSystemInfo; Begin. GetSystemInfo(SysInfo); If SysInfo.dwProcessorType=386. Then GenericCpuN:=''Generic 386 CPU'' Else. If SysInfo.dwProcessorType=486. Then GenericCpuN:=''Generic 486 CPU'' Else. If SysInfo.dwProcessorType=586. Then GenericCpuN:=''Pentium Class CPU'' Else GenericCpuN:=''Unknown CPU''; End; Function TCpuData.P5CacheL1DI:word; Begin. If CheckMMX then P5CacheL1DI:=16. Else P5CacheL1DI:=8; End; Function TCpuData.P6CacheL1DI:word; Begin. If not CheckMMX then P6CacheL1DI:=8. Else P6CacheL1DI:=16; End; Function TCpuData.P6CacheL2:word; Var Family,Model,Stepping:byte; Begin. If CheckCeleron then P6CacheL2:=128. Else. If CheckPentiumIII then begin. GetFMS(Family,Model,Stepping); If Model=7 then P6CacheL2:=512. Else if Model=8 then P6cacheL2:=256. Else P6CacheL2:=512; End. Else if not CheckMMX then P6CacheL2:=512. Else P6CacheL2:=512; End; Function TCpuData.AuthenticAMD:TCpuRec; Var Family,Model,Stepping:byte; EFamily,EModel,EStepping:byte; Begin. GetFMS(Family,Model,Stepping); If Family=4 then begin. AuthenticAMD.Name:=''AMD 486''; AuthenticAMD.Vendor:=GetVendorString; AuthenticAMD.Frequency:=0; AuthenticAMD.Family:=Family; AuthenticAMD.Model:=Model; AuthenticAMD.Stepping:=Stepping; AuthenticAMD.L1DCache:=8; AuthenticAMD.L1ICache:=8; AuthenticAMD.L2Cache:=0; End. Else. If Family=5 then begin. If GetMaxExtendedFunctions>4 then. Begin. AuthenticAMD.Name:=GetExtendedCpuName; AuthenticAMD.Vendor:=GetVendorString; AuthenticAMD.Frequency:=GetCPUFrequency; GetExtendedFMS(EFamily,EModel,EStepping); AuthenticAMD.Family:=EFamily; AuthenticAMD.Model:=EModel; AuthenticAMD.Stepping:=EStepping; AuthenticAMD.L1DCache:=GetExtendedL1DCache; AuthenticAMD.L1ICache:=GetExtendedL1ICache; AuthenticAMD.L2Cache:=0; End. Else. Begin. AuthenticAMD.Name:=AMDK5N; AuthenticAMD.Vendor:=GetVendorString; AuthenticAMD.Frequency:=GetCPUFrequency; AuthenticAMD.Family:=Family; AuthenticAMD.Model:=Model; AuthenticAMD.Stepping:=Stepping; AuthenticAMD.L1DCache:=16; AuthenticAMD.L1ICache:=16; AuthenticAMD.L2Cache:=0; End; End. Else if family>5 then. Begin. AuthenticAMD.Name:=GetExtendedCpuName; AuthenticAMD.Name:=GetExtendedCpuName; AuthenticAMD.Vendor:=GetVendorString; AuthenticAMD.Frequency:=GetCPUFrequency; GetExtendedFMS(EFamily,EModel,EStepping); AuthenticAMD.Family:=EFamily; AuthenticAMD.Model:=EModel; AuthenticAMD.Stepping:=EStepping; AuthenticAMD.L1DCache:=GetExtendedL1DCache; AuthenticAMD.L1ICache:=GetExtendedL1ICache; AuthenticAMD.L2Cache:=GetExtendedL2Cache; End; End; Function TCpuData.GenuineIntel:TCpuRec; Var Family,Model,Stepping:byte; Begin. GetFMS(Family,Model,Stepping); If Family=4 then begin. GenuineIntel.Name:=''Intel 486''; GenuineIntel.Vendor:=GetVendorString; GenuineIntel.Frequency:=0; GenuineIntel.Family:=Family; GenuineIntel.Model:=Model; GenuineIntel.Stepping:=Stepping; GenuineIntel.L1DCache:=8; GenuineIntel.L1ICache:=8; GenuineIntel.L2Cache:=0; End. Else. If Family=5 then begin. GenuineIntel.Name:=IntelP5N; GenuineIntel.Vendor:=GetVendorString; GenuineIntel.Frequency:=GetCPUFrequency; GenuineIntel.Family:=Family; GenuineIntel.Model:=Model; GenuineIntel.Stepping:=Stepping; GenuineIntel.L1DCache:=P5CacheL1DI; GenuineIntel.L1ICache:=P5CacheL1DI; GenuineIntel.L2Cache:=0; End. Else. If Family=6 then begin. GenuineIntel.Name:=IntelP6N; GenuineIntel.Vendor:=GetVendorString; GenuineIntel.Frequency:=GetCPUFrequency; GenuineIntel.Family:=Family; GenuineIntel.Model:=Model; GenuineIntel.Stepping:=Stepping; GenuineIntel.L1DCache:=P6CacheL1DI; GenuineIntel.L1ICache:=P6CacheL1DI; GenuineIntel.L2Cache:=P6CacheL2; End. Else. If Family=$F then begin. If CheckPentium4 then. Begin. GenuineIntel.Name:=''Intel Pentium(r) 4''; GenuineIntel.Vendor:=GetVendorString; GenuineIntel.Frequency:=GetCPUFrequency; GenuineIntel.Family:=32; GenuineIntel.Model:=Model; GenuineIntel.Stepping:=Stepping; GenuineIntel.L1DCache:=8; GenuineIntel.L1ICache:=12; GenuineIntel.L2Cache:=256; End. Else if CheckIthanium then. Begin. GenuineIntel.Name:=''Intel Ithanium''; GenuineIntel.Vendor:=GetVendorString; GenuineIntel.Frequency:=GetCPUFrequency; GenuineIntel.Family:=64; GenuineIntel.Model:=Model; GenuineIntel.Stepping:=Stepping; GenuineIntel.L1DCache:=0; GenuineIntel.L1ICache:=0; GenuineIntel.L2Cache:=0; End; End; End; Function TCpuData.CyrixInstead:TCpuRec; Var Family,Model,Stepping:byte; EFamily,EModel,EStepping:byte; Begin. GetFMS(Family,Model,Stepping); If Family=4 then begin. CyrixInstead.Name:=''VIA Cyrix 4x86''; CyrixInstead.Vendor:=GetVendorString; CyrixInstead.Frequency:=0; CyrixInstead.Family:=Family; CyrixInstead.Model:=Model; CyrixInstead.Stepping:=Stepping; CyrixInstead.L1DCache:=8; CyrixInstead.L1ICache:=8; CyrixInstead.L2Cache:=0; End. Else. If Family=5 then begin. CyrixInstead.Name:=''VIA Cyrix 5x86''; CyrixInstead.Vendor:=GetVendorString; CyrixInstead.Frequency:=GetCPUFrequency; CyrixInstead.Family:=Family; CyrixInstead.Model:=Model; CyrixInstead.Stepping:=Stepping; CyrixInstead.L1DCache:=8; CyrixInstead.L1ICache:=8; CyrixInstead.L2Cache:=0; End. Else begin. If GetMaxExtendedFunctions>0 then. Begin. CyrixInstead.Name:=GetExtendedCpuName; CyrixInstead.Vendor:=GetVendorString; CyrixInstead.Frequency:=GetCPUFrequency; GetExtendedFMS(EFamily,EModel,EStepping); CyrixInstead.Family:=EFamily; CyrixInstead.Model:=EModel; CyrixInstead.Stepping:=EStepping; CyrixInstead.L1DCache:=GetExtendedL1DCache; CyrixInstead.L1ICache:=GetExtendedL1ICache; CyrixInstead.L2Cache:=GetExtendedL2Cache; End. Else begin. CyrixInstead.Name:=Cyrix686N; CyrixInstead.Vendor:=GetVendorString; CyrixInstead.Frequency:=GetCPUFrequency; CyrixInstead.Family:=Family; CyrixInstead.Model:=Model; CyrixInstead.Stepping:=Stepping; CyrixInstead.L1DCache:=32; CyrixInstead.L1ICache:=32; CyrixInstead.L2Cache:=0; End; End; End; Function TCpuData.GenericCPU:TCpuRec; Var Family,Model,Stepping:byte; EFamily,EModel,EStepping:byte; Begin. If not GetCPUIDSupport then. Begin. MessageDlg(''This CPU does not support the CPUID instruction!!!'',mtWarning, [mbOk],0); GenericCPU.Name:=''Unidentified CPU''; GenericCPU.Vendor:=''Unidentified''; GenericCPU.Frequency:=0; GenericCPU.Family:=-1; GenericCPU.Model:=-1; GenericCPU.Stepping:=-1; GenericCPU.L1DCache:=0; GenericCPU.L1ICache:=0; GenericCPU.L2Cache:=0; End. Else. Begin. GetFMS(Family,Model,Stepping); If GetMaxExtendedFunctions>0 then. Begin. GenericCPU.Name:=GetExtendedCPUName; GenericCPU.Vendor:=GetVendorString; GenericCPU.Frequency:=GetCPUFrequency; CpuData.GetExtendedFMS(EFamily,EModel,EStepping); GenericCPU.Family:=EFamily; GenericCPU.Model:=EFamily; GenericCPU.Stepping:=EStepping; GenericCPU.L1DCache:=GetExtendedL1DCache; GenericCPU.L1ICache:=GetExtendedL1ICache; GenericCPU.L2Cache:=GetExtendedL2Cache; End. Else begin. GenericCPU.Name:=GenericCpuN; GenericCPU.Vendor:=GetVendorString; If Family<=4 then GenericCPU.Frequency:=0. Else GenericCPU.Frequency:=GetCPUFrequency; GenericCPU.Family:=Family; GenericCPU.Model:=Model; GenericCPU.Stepping:=Stepping; GenericCPU.L1DCache:=0; GenericCPU.L1ICache:=0; GenericCPU.L2Cache:=0; End; End; End; End.

Как перехватить нажатие TAB?

Code: Private. {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Procedure CMDialogKey(Var Msg: TWMKey); message CM_DIALOGKEY; ..... Procedure TForm1.CMDialogKey(var Msg: TWMKey); Begin. //здесь Ваш код. Msg.Result := 0. End;

©Drkb::01477.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.

Code: 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;

©Drkb::01478.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Автор: Ralph Friedman.

Как найти окно по неполному названию?

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

Code: Type. PFindWindowStruct = ^TFindWindowStruct; TFindWindowStruct = record. Caption: string; ClassName: string; WindowHandle: THandle; End; Function EnumWindowsProc(hWindow: hWnd; lParam: LongInt): Bool; stdcall; 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. WindowInfo.Caption := Caption; WindowInfo.ClassName := ClassName; WindowInfo.WindowHandle := 0; EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); FindAWindow := WindowInfo.WindowHandle; End; Procedure TForm1.Button1Click(Sender: TObject); Var TheWindowHandle: THandle; Begin. TheWindowHandle := FindAWindow('Opera', ''); If TheWindowHandle <> 0 then. Begin. Showwindow(TheWindowHandle, sw_restore); BringWindowToTop(TheWindowHandle); End. Else. ShowMessage('Window Not Found!'); End;

Какой язык на данный момент на клавиатуре?

Используй GetKeyboardLayoutName.

Автор ответа: Mikel.

©Drkb::01953.

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: Var. {©Drkb v.3(2007): www.drkb.ru}. Form1: TForm1; LAYOUT: String; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Var. RA: Array[0..$FFF] of Char; Begin. GetKeyboardLayoutName(RA) ; Layout := StrPas(RA); If Layout = '00000419' then. Showmessage(' CCCP ' ). Else. If Layout = '00000409' then. Showmessage(' USA ' ). Else. Showmessage(' X 3 ' ) ; End;

Помогите спрятать программу из списка задач?

Или Как заказать сервисный процесс ?

Code: Unit Stealth; Interface. Uses. WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages; Type. TStealth = class(TComponent). Private. FHideApp: Boolean; Procedure SetHideApp(Value: Boolean); Protected. { Protected declarations }. Procedure HideApplication; Procedure ShowApplication; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; // procedure Loaded; override; Published. { Published declarations }. Property HideApp: Boolean read fHideApp write SetHideApp default false; End; Function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; Procedure Register; Implementation. Destructor TStealth.Destroy; Begin. ShowApplication; Inherited destroy; End; Constructor TStealth.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); // fHideform := true; End; Procedure TStealth.SetHideApp(Value: Boolean); Begin. FHideApp := Value; If Value then HideApplication else ShowApplication; End; Procedure TStealth.HideApplication; Begin. If not (csDesigning in ComponentState) then. RegisterServiceProcess(GetCurrentProcessID, 1); End; Procedure TStealth.ShowApplication; Begin. If not (csDesigning in ComponentState) then. RegisterServiceProcess(GetCurrentProcessID, 0); End; Procedure Register; Begin. RegisterComponents('My', [TStealth]); End; End.

Как с помощью API поместить Label на Form?

Code: Var. HLabel : HWND ; ... HLabel := CreateWindow ( 'STATIC', 'test', WS_CHILD or WS_VISIBLE, 0, 0, 200, 40, hWnd, NULL, hInstance, NULL );

Как обновить рабочий стол?

Code: Procedure RefreshDesktop; {©Drkb v.3(2007): www.drkb.ru}. Var. C1 : cardinal; Begin. C1:=FindWindowEx(FindWindowEx(FindWindow('Progman','Program Manager'),,'SHELLDLL_DefView',''),0,'SysListView32',''); PostMessage(c1,WM_KEYDOWN,VK_F5,0); PostMessage(c1,WM_KEYUP,VK_F5,1 shl 31); End;

Как сменить обои на рабочем столе?

В принципе, все настройки на фоновый рисунок хранятся в реестре. Поэтому надо сначала скопировать картинку в какое-нибудь место (лучше в каталог Виндов) на случай удаления или переноса исходного файла. Информация по обоям хранится в разделе HKEY_CURRENT_USER\Control Panel\Desktop в параметрах TileWallpaper (если 1 - рисунок размножен, 0 - в центре), Wallpaper - путь к файлу обоев (gif, bmp, jpg), WallpaperStyle - если 2, то обои будут растянуты (отсутствует в 95 винде).

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

Автор ответа: Garik.

©Drkb::01811.

Взято с Vingrad.ru http://forum.vingrad.ru.

Смена обоев только на время текущего сеанса, после перезагрузки обои восстановятся:

Code: Var Wallpaper : string; {©Drkb v.3(2007): www.drkb.ru}. Begin. Wallpaper := 'C:\windows\ACD Wallpaper.bmp'; SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, PChar(Wallpaper), SPIF_SENDCHANGE). End;

Как послать нажатие клавиши в какое-нибудь окно?

Эта процедура посылает сообщение о нажатии клавиши.

Code: Procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Type TShiftKeyInfo = record. Shift: Byte; Vkey: Byte; End; Byteset = set of 0..7; Const shiftkeys: array[1..3] of TShiftKeyInfo = ((shift: Ord(ssCtrl); Vkey: VK_CONTROL), (shift: Ord(ssShift); vkey: VK_SHIFT), (shift: Ord(ssAlt); vkey: VK_MENU)); Var flag: DWORD; BShift: ByteSet absolute shift; I: Integer; Begin. For i := 1 to 3 do. If shiftkeys[i].shift in bShift then. Keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0); If specialkey then. Flag := KEYEVENTF_EXTENDEDKEY. Else. Flag := 0; Keybd_event(key, MapvirtualKey(key, 0), flag, 0); Flag := flag or KEYEVENTF_KEYUP; Keybd_event(key, MapvirtualKey(key, 0), flag, 0); For i := 3 downto 1 do. If shiftkeys[i].shift in bShift then. Keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), KEYEVENTF_KEYUP, 0); End;

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

Code: SetForegroundWindow(FindWindow(PChar(WindowClassName), PChar(WindowCaption)));

PS. не забудьте поставить задержки типа Sleep(100) после активизации окна и между посылаемыми клавишами, не то окно может не успевать реагировать на клавиши...

©Drkb::01490.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как програмно имитировать нажатие Ctrl-Esc?

Code: SendMessage(Handle,WM_SYSCOMMAND,SC_TASKLIST,0);

Автор ответа: TwoK.

©Drkb::01491.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как запустить программу и подождать ее завершения?

Code: Var. Pi : TProcessInformation; Si : TStartupInfo; Begin. ZeroMemory(@si,sizeof(si)); Si.cb:=SizeOf(si); If not CreateProcess( PChar(lpApplicationName), //pointer to name of executable module. PChar(lpCommandLine), // Command line. Nil, // Process handle not inheritable. Nil, // Thread handle not inheritable. False, // Set handle inheritance to FALSE. 0, // No creation flags. Nil, // Use parent's environment block. Nil, // Use parent's starting directory. Si, // Pointer to STARTUPINFO structure. Pi ) // Pointer to PROCESS_INFORMATION structure. Then begin. Result:=false; RaiseLastWin32Error; Exit; End; WaitForSingleObject(pi.hProcess,INFINITE); CloseHandle(pi.hProcess); CloseHandle(pi.hThread); // ... здесь твой код. End;

Как изменить системное время?

Функция SetSystemTime.

Обрати внимание на привилегии.

Автор ответа: podval.

©Drkb::01638.

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: //********************************************************** // Функция (раздел Public) SetPCSystemTime изменяет системную дату и время. // Параметр(ы) : tDati Новая дата и время. // Возвращаемые значения: True - успешное завершение. // False - метод несработал. //************************************************************ Function SetPCSystemTime(tDati: TDateTime): Boolean; Var. TSetDati: TDateTime; VDatiBias: Variant; TTZI: TTimeZoneInformation; TST: TSystemTime; Begin. GetTimeZoneInformation(tTZI); VDatiBias := tTZI.Bias / 1440; TSetDati := tDati + vDatiBias; With tST do. Begin. WYear := StrToInt(FormatDateTime('yyyy', tSetDati)); WMonth := StrToInt(FormatDateTime('mm', tSetDati)); WDay := StrToInt(FormatDateTime('dd', tSetDati)); WHour := StrToInt(FormatDateTime('hh', tSetDati)); WMinute := StrToInt(FormatDateTime('nn', tSetDati)); WSecond := StrToInt(FormatDateTime('ss', tSetDati)); WMilliseconds := 0; End; SetPCSystemTime := SetSystemTime(tST); End;

©Drkb::01639.

Для изменения системного времени используется сложный спобой (через строки).

Code: DateTimeToSystemTime(tSetDati,Tst);

- работает быстрее и код короче.

©Drkb::01640.

Code: {©Drkb v.3(2007): www.drkb.ru}. Procedure settime(hour, min, sec, hundreths : byte); assembler; Asm. Mov ch, hour. Mov cl, min. Mov dh, sec. Mov dl, hundreths. Mov ah, $2d. Int $21. End; //////////////////////////////////////////////////////////////////////// Procedure setdate(Year : word; Month, Day : byte); assembler; Asm. Mov cx, year. Mov dh, month. Mov dl, day. Mov ah, $2b. Int $21. End;

Особенности работы события onActivate.

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

Виной тому виндовые API. Помните начиная с 98 виндов возникла фича - когда активация окна приводит к мельканию заголовка в таскбаре. Под win95/NT4 событие формы onActivate происходит только в момент показа формы (Show, ShowModal), а в остальных осях может возникать и просто при попадании фокуса на форму (уж не знаю почему, но не всегда). Есть хороший способ избавиться от такого поведения и заставить это событие возникать только 1 раз при активации формы и в дальнейшем только тогда когда это нужно.

Code: Procedure TForm1.Form1OnActivate(Sender:TObject); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Begin. OnActivate:=nil; {здесь ваш код обработки события}. End;

Базы данных с нуля (статья).

Итак, решил я открыть серию статей для помощи в овладении основными навыками программирования баз данных (БД, или DB - database). Я буду рассчитывать, что читатель имеет понятие о программировании в Дельфи, но абсолютно не знаком с базами данных. Первые несколько постингов будут о базах данных вообще, поэтому прошу не ругать меня - это не офтопик, очень быстро мы доберёмся до Дельфи.

©Drkb::02460.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Что такое базы данных?

Итак базы данных существуют следующих видов:

1) Древовидные - простейший пример - Windows Registry, файловая система FAT и XML - здесь информация хранится в древовидной структуре и доступ осуществляется через "путь", т.е. указание всех узлов от корневого до нужного. Например: "c:\My Docs\MyPictures\Me.jpg". Недостатки этого способа хранения данных является очень медленный поиск, если не известен путь и очень плохая устойчивость к повреждениям структуры. Преимущество - возможность хранить в классифицированном виде очень разнородную информацию и очень быстрый поиск при знании ключа. Эти базы данных мы разбирать здесь не будем.

2) Сетевые базы данных - простейший пример - интернет. Т.е. существуют узлы, обособленные друг от друга, содержащие определённую информацию. Каждый узел представляет какое-то количество ссылок на другие узлы, по которым и ведётся поиск. Недостатки - очень сложный и долгий поиск, возможна неполное предоставление информации или невозможность найти нужную информацию. Преимущества - очень легко добавить любую, разнородную информацию, самая высокая стабильность из всех систем. Эти базы данных мы разбирать здесь не будем.

3) Объектные базы данных - новое веяние. Их мы разбирать здесь не будем, но интересующиеся найдут интересной дискуссию о них в нашем разделе по базам данных.

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

Реляционные базы данных?

Итак, Реляционная база данных упрощённо является набором таблиц. Таблица же есть основной строительный кирпичик базы данных. Расмотрим структуру таблицы. Для начала представте себе таблицу, например в Word...

Что в ней есть?

Во-первых есть строки и колонки (raw and columns). В базах данных, в отличие от Word есть строгие ограничения на их содержимое, да и терминология немного другая:

1) Колонка называется тоже columns, но чаще употребляется понятие "поле" (field). Колонка всегда имеет имя (по которому ее можно найти) и обязана хранить данные только одного какого-либо типа - например целые числа, строки, дату/время и т.п. Создавая таблицу вы обязаны указать какой тип имеет каждое поле, другими словами, вы заранее должны определится, какого сорта данные будут хранится в колонке. Например, вот примерно так может выглядеть структура таблицы для хранения данных об участнике этого форума:

· Ник - строка (25 символов)

· ФИО - строка (250 символов)

· Дата регистрации - Дата/время

· Количество постингов - Целое

· Показывать email - True/False

Обратите внимание что для строк я указал конкретную длину, а для остальных ничего не указывал. Зачем? Ответ прост - каждая строка должна занимать строго одинаковое место (об исключениях потом), и это сделано для быстроты поиска. Действительно , если бы каждая строка имела разную длину, то чтобы найти например 1000 строку, надо было бы перечитать все 999 предыдущих строк, но если известно, что каждая строка занимает например 1Кб, то чтобы прочитать 1000 строку достаточно прочитать 1 Кб с 999Кб... Другая сторона этого - например мне надо сравнить даты в приведенной выше таблице - сделать это просто - я точно знаю что первую дату можно прочитать с 276 байта, и так же точно я знаю точные координаты каждой даты. Именно в этом и лежит одна из сторон высокой скорости работы баз данных (другие способы ускорения работы рассмотрим позже).

2) Строка - в базах данных имеет специфическое название - запись (Record) - к Дельфийскому типу Record этот термин не имеет никакого отношения. Хотя большинство БД дают возможность перейти и прочитать например 10 запись, надо с самого начала попытаться никогда этим не пользоваться. Почему? Да просто потому что БД практически всегда подразумевают совместный доступ нескольких пользователей к одним и тем же данным, и если Вы хотите перейти на 10 запись, а другой пользователь в это время удалит запись номер 5, то вы перейдёте вовсе не на ту запись что ожидалось. А как же быть? У вас есть 2 способа - либо вы находите нужную запись по значению поля - например для нашей таблицы это будет выглядеть примерно так:

"Найти пользователя [Вася] в первой колонке".

В результате вы получите доступ ко всем полям записи для "Васи". Либо вы берёте все записи и перебираете их в цикле пока не найдёте нужный - это гораздо худший способ, так как работает на 2-3 порядка медленнее и имеет другие неприятные последствия (об этом позже), но он возможен и иногда применяется.

Первая программа с базами данных?

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

Открываем новый проект. Открываем форму. Кладём на форму компонент TTable (с закладки "Data Access" или "BDE" - у кого какая версия Дельфей). Оп! Не ожидали - вроде бы и таблица, а компонт не визуальный! Итак компонент TTable - это пока основной компонент для нашей базы - всё обращение к таблице идёт только через него. Теперь давай-те его подсоединим к базе данных.

К Дельфи прилогается учебная база данных, её мы и будем пользовать. Найдите свойство DatabaseName и из выпадающего списка выберите "DBDEMOS" - это и есть учебная база данных. Теперь берём свойство TableName и в выпадающем списке обнаруживаем список имён всех таблиц в базе данных "DBDEMOS", выбираем например "biolife.db" - это таблица так называется (а в данном случае и название файла).

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

Но все визуальные компоненты могут подсоединится к TTable только через вспомогательный компонент TDataSource - находящийся на той же закладке. Ставим и его на форму. Находим свойство DataSet у этого компонента и в выпадающем списке указываем на Table1. Теперь визуальные компоенты будут "видеть" инфу в таблице через TDataSource.

Переходим на другую закладку компонентов - "Data Controls" и ставим компоент TDBGrid. В его свойстве DataSource указываем на DataSource1. Что видим? Пока ничего! Таблица то не открыта - кликаем на Table1 и устанавливаем свойство Active в True. Работает!

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

Визуальные компоненты для DB.

Итак, мы не написав ни строчки кода получили простейшее приложение, работающее с базой данных. С помощью него мы можем просматривать и редактировать содержимое таблицы. Давайте теперь сделаем эту процедуру немного удобнее, на закладке "Data Control" есть компонент TDBNavigator. Положим его на форму и в инспекторе объектов поставим его свойство DataSource указывающим на тот же DataSource1, что и для DBGrid - собственно, теперь оба визуальных контрола(DBGrid и DBNavigator) привязаны к одному и тому же DataSource и через него к одной и той же таблицы. DBNavigator имеет несколько кнопок (вы можете настроить какие именно вы хотите видеть) дающие лёгкий контроль над следующими операциями:

(перечисление в порядке расположения кнопок).

1) Переход на первую запись

2) Переход на предыдущую запись

3) Переход на следующую запись

4) Переход на последнюю запись

5) Добавить запись

6) Удалить запись

7) Редактировать запись

8) Сохранить изменения

9) Отменить изменения

10) Перечитать таблицу

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

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

На закладке Data Controls есть ещё несколько важных компонентов, давайте поставим их на нашу форму: DBLabel, DBEdit, DBMemo и DBImage. Все их так же как и DBGrid соединим с DataSource1. Однако здесь мы обнаружим что этого недостаточно, эти компоненты работают с отдельной ячейкой в таблице, поэтому мы должны указать ещё поле (столбец) который они будут показывать.

Давайте сделаем следуюшие - для каждого из этих компонентов укажем свойство DataField, например следующим образом:

DBLabel - ассоциируем с полем Category.

DBEdit - ассоциируем с полем Common_name.

DBMemo - ассоциируем с полем Notes.

DBImage - ассоциируем с полем Graphic.

Можно откомпилировать программу и немного поиграться с ней. Итак что мы можем здесь увидеть? Что в каждый данный момент времени из всей таблицы у нас есть запись которая активная (текущая) - в DBGrid она показывается треугольничком слева. Именно с этой единственной записью мы и можем оперировать - удалять, добавлять, редактировать, именно её содержимое отображается в DBLabel, DBEdit, DBMemo, DBImage и именно она может быть изменена при помощи этих компонентов. Описанная только что структура позволяет работать только с одной записью в определённый момент времени, если вы переходите на другую запись то все изменения должны быть либо запомнены либо отменены! По умолчанию они запоминаются без всяких запросов, в чём вы можете убедиться меняя значения и переходя на другую запись.

Работа с таблицами в коде.

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

Итак, начинаем разбирать способы работы с базами данных в коде.

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

Table1. Сразу предупреждаю - КАТЕГОРИЧЕСКИ НЕ СЛЕДУЕТ ПЫТАТЬСЯ ИЗ.

КОДА МЕНЯТЬ ЗНАЧЕНИЯ В ВИЗУАЛЬНЫХ КОМПОНЕНТАХ, не следует пытаться.

Менять или читать значения из DBGrid, DBEdit и т.д. Эти компоненты.

Существуют только для работы оператора "вручную". Для доступа к.

Данным из кода надо использовать только невизуальные компоненты.

Типа TTable (в дальнейшем мы разберём и другие компоненты для работы.

С данными - но в любом случае это будут не визуальные компоненты).

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

Надо определить столбец(поле) и строку(запись) в которой эти данные.

Находятся. Давайте разбирать по очереди.

1) Определить поле задача очень простая. Способов здесь 2:

Или по имени:

Table1.FieldByName('Category').

Или по номеру столбца.

Table1.Fields[1].

Оба выражения являются объектом наследованным от типа TField.

Я не буду разбирать этот объект подробно, только приведу пример.

Как можно пользоваться этим объектом для доступа к содержимому.

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

Использовать следующие методы в зависимости от типа данных:

Code: Table1.FieldByName('Category').AsString. Table1.FieldByName('Category').AsInteger. Table1.FieldByName('Category').AsBoolean. Table1.FieldByName('Category').AsDateTime. Table1.FieldByName('Category').AsFloat.

Поиск нужных данных.

Теперь разберём более эффективные способы нахождения нужной записи.

В таблице.

А если нам надо перейти к вполне конкретной строке (записи)? Можно конечно.

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

И главное очень медлено! Для этого можно использовать метод таблицы Locate.

Например в нашей задаче нам надо найти запись где в поле Category значение.

"Cod". Этого можно добится примерно следующим кодом:

Table1.Locate('Category','Cod',[loCaseInsensitive]);

Можно "повесить" этот код на кнопку и убедится, что после выполнения этого.

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

Мы передаём этому методу? Первый параметер - это имя поля, второй параметер -

Это значение поля, третий опции поиска (см. справку Дельфи). А что будет если.

Такого значения нет? Например:

Table1.Locate('Category','Cod123',[loCaseInsensitive]);

Ничего не будет, правда метод Locate - это функция и она возвращает значение Boolean.

В зависимости от того, найдена запись или нет.

Преобразовав код как.

If Table1.Locate('Category','Cod123',[loCaseInsensitive]) then.

Showmessage('Record is located seccessful!').

Else.

Showmessage('Record is not found!');

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

Значения, например.

Table1.Locate('Category','Co',[]).

Не сможет найти запись, а.

Table1.Locate('Category','Co',[loPartialKey]).

Вполне правильно найдёт запись с значением 'Cod'.

А если нам надо найти значение по двум полям? В этой таблице искать так бесполезно,

Так как все поля разные. Переключим таблицу на другую. Для этого удалим с формы.

Все визуальные компоненты кроме DBGrid и DBNavigator (так как у новой таблицы.

Будет совсем другой список полей). В коде напишем что-то.

Типа:

Code: Table1.active:=false; //закрыли таблицу. Table1.tablename:='items.db';//ассоциируем с новой таблицей на диске. Table1.active:=true; //открыли таблицу.

Доступ к базам данных.

Теперь, после работы руками, попробуем разобрать несколько менее призёмлённых вещей. Для начала следует упомянуть что Вы наверное уже прочуствовали что такое таблица. Теперь немного остановимся на базе данных. Базу данных можно очень упрощённо представить как несколько разных таблиц. Они могут быть связаны между собой, а могут и нет. Как физически хранятся таблицы? В трёх видах:

1) Каждая таблица это отдельный файл. Так работают наиболее древние базы данных, например Парадокс (который мы пока используем в примерах), Dbase, FoxPro. Все файлы таблиц лежат в отдельном каталоге на диске. Этот каталог и называется базой данных.

2) Все таблицы хранятся в одном файле – например MS Access – именно этот файл и называется базой данных.

3)Таблицы хранятся на специальном сервере – например MS SQL Server, Oracle. В данном случае нас вообще не интересует как сервер хранит эти таблицы – для нас прямой доступ к ним закрыт, мы можем лишь послать запрос на сервер и получить ответ.

Несмотря на значительную разницу в организации, работа с разными базами данных очень сходная (во всяком случае до углубления в дебри). В целом, Вам нет смысла копаться в реальных форматах файлов, нет смысла искать что в файле biolife.db означает 10й байт. Может показаться что всю работу над этим файлом делает компонент TTable в нашем примере. Но это не так! Я наверное удивлю многих если скажу, что компонент TTable реально является только интерфейсом, для лёгкого доступа к данным из Дельфи. Оказывается, что всю работу над таблицей делает специальный драйвер базы данных (или его ещё называют провайдер). Итак упрощённая схема общения с таблицей из программы выглядит примерно следующим образом(для нашего примера):

База Данных <-> Драйвер Базы Данных <-> TTable <-> наш код или др. компоненты.

Итак драйвер БД «знает» тонкости и детали строения файла таблицы, или знает конкретные форматы запроса к серверу на «входе», а на выходе имеет некий универсальный «интерфейс» (Я имею ввиду широкое понятие слова «интерфейс», вне контекста с COM) к которому и подключается TTable. Естественно что каждая база данных, и даже каждая версия базы данных имеет свой уникальный формат, свои уникальные особенности, поэтому драйвер для каждой разновидности баз данных тоже уникальный и обычно создаётся производителем баз данных. Интерфейс на «выходе» тоже должен быть стандартизованным – тогда работа с разными базами данных будет значительно облегчена, конечно до истиной переносимости кода далеко (хотя для простейших програм можно легко перенести код для работы с другой базой данных) – сказываются очень большие различия в архитектуре баз данных, которые просто невозможно свести 100% к одинаковому интерфейсу, но в любом случае знакомство с одной базой данных позволяет с лёгкостью разобраться с другой... Как всегда существует несколько стандартов таких «выходных интерфейсов». Наиболее широкораспространены следующие «стандарты» или системы доступа к базам данных:

1)BDE – Borland Database Engine (или по-старому IDAPI). Мы как раз работали в наших примерах именно через эту систему. Эта система является «родной» для Дельфи и отличается весьма высокой производительностью при работе с локальными базами данных. С серверными базами данных её производительность гораздо скромнее. Она же является «родной» для Парадокса, что обусловливает очень высокую производительность и удобство работы связки Delphi-BDE-Paradox (конечно для небольших систем с малым количеством пользователей). BDE имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Позже мы подробнее остановимся на настройке BDE.

2)ODBC – продукт был создан Microsoft как конкурент BDE. На большинстве баз данных он показывает меньшую производительность чем BDE, из Дельфи с ним работать не так удобно, но он так же имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Его настройки можно найти в «Панели Управления» Windows. Есть бесплатная библиотека компонентов для работы с ODBC с исходными кодами, её можно взять с моего сайта: http://www.delphist.com. Для программиста на Дельфи представляет очень ограниченный интерес – большинство возможностей реализовано в BDE, причём BDE со многими базами работает быстрее и Дельфи имеет собственные компоненты для BDE.

3)DAO – это очень старая система для доступа к MS Access и MS Excel (она так же поддерживает ещё несколько баз данных), отличается высокой производительностью и богатым набором функций для работы именно с MS Access и MS Excel. Вообще не поддерживает работу с серверными базами данных. DAO можно использовать для работы с MS Access и MS Excel когда критична производительность приложений и/или требуется всё богатство возможностей доступа к MS Access и MS Excel. Есть бесплатная библиотека компонентов для работы с DAO с исходными кодами, её можно взять с моего сайта: http://www.delphist.com.

4)ADO (ActiveX Data Object) – новая система от MS ориентированная прежде всего на работу с серверными базами данных. Довольно удобна в использовании, Дельфи начиная с 4й версии в модификации Enterprise/Professional имеет линейку собственных компонентов для работы через ADO. Позднее мы рассмотрим работу с ADO компонентами.

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

Приёмы работы с BDE.

Те примеры с которыми мы работали использовали именно BDE. Давайте рассмотрим вопросы, напрямую связанные с BDE:

1) Где физически хранится моя база данных.

2) Как создать базу данных.

3) Как создать таблицу.

Итак, где физически хранится моя база данных и собственно куда мы обращались в наших примерах? Если вы помните, в наших примерах мы свойство DatabaseName для Table установили в "DBDemos". Что же это такое "DBDemos"? - это название базы данных, или в терминологии BDE - Alias (перевод на русский язык "Псевдоним"). Alias - это некая "структура" BDE, которая указывает на физическое расположение файлов базы данных, а так же хранит некоторые свойства (параметры) доступа к базе данных. Эти параметры можно посмотреть, настроить, а также добавить или удалить Alias используя программу "BDE Administrator" которую можно найти в Control Panel (панель управления Windows). Запустите BDE Administrator и найдите в левом дереве DBDemos. Теперь на правой части можно увидеть его свойства, например там вы найдёте путь к базе данных. С помощью BDE можно удалить Alias или добавить новый.

Как открыть окно настройки даты и времени Windows?

Code: Shellexecute(handle, 'Open', 'Rundll32.exe', 'shell32.dll,Control_RunDLL TIMEDATE.CPL', Pchar(Getsystemdir), 0);

Создание базы данных.

Итак, Как создать базу данных?

Пока мы рассматриваем Paradox осмелюсь заметить, что база данных ничто иное как папка (каталог) на диске. Надеюсь что читателю не составит труда создать пустой каталог, например "c:\MyDBExample". Теперь создадим Alias на этот каталог:

1) Открываем BDE Administrator, нажимаем menu->Object->New (или Ctrl-N).

2) В выскочившем окне выбираем Standard, жмём Ok.

3) На левой панеле переименовываем название Alias во что-нибудь, например "MyDB".

4) На правой панеле, в разделе PATH указываем c:\MyDBExample.

5) Сохраняем изменения.

Закрываем BDE Administrator. Загружаем Дельфи с нашим примером, убеждаемся, что в свойстве DatabaseName у таблицы появился среди вариантов выбора и наш Alias - "MyDB".

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

С созданием базы данных програмно большие проблемы! Задача состоит из 2х этапов:

1) Создание самой базы данных.

2) Создание Alias.

Второй вопрос весьма прост - используются методы системного объекта Session:

Session.AddAlias.

Session.SaveConfigFile.

Ответ же на первый не однозначен и вызвано это тем, что это целиком зависит от базы данных. Так как Dbase и Paradox базы данных это просто каталоги, то тут проблем нет, создаём каталог (ForceDirectories например) и дело с концом, для MS Access и MS Excel уже прийдётся использовать DAO низкоуровневые функции, серверные базы данных обычно имеют системные Stored Procedures для создания базы данных.

Создание таблицы.

Как создать таблицу ?

Вариантов несколько:

1) Сделать это с помошью менеджера соответствующей базы данных, например таблицу для Paradox создать в Paradox'e.

2) С помощью Database Desktop - утилита , постовляемая с BDE и большинством борландовских продуктов. Я не думаю что вы встретите проблемы при создании таблицы - там всё очень просто.

3) Из программы.

Здесь 2 варианта, вариант первый, использовать метод CreateTable у таблицы, вот пример из справки по Дельфи как Борланд предлагает это делать:

Code: With Table1 do begin. Active := False; DatabaseName := 'DBDEMOS'; TableType := ttParadox; TableName := 'CustInfo'; { Don't overwrite an existing table }. If not Table1.Exists then begin. { The Table component must not be active }. { First, describe the type of table and give }. { it a name }. { Next, describe the fields in the table }. With FieldDefs do begin. Clear; With AddFieldDef do begin. Name := 'Field1'; DataType := ftInteger; Required := True; End; With AddFieldDef do begin. Name := 'Field2'; DataType := ftString; Size := 30; End; End; { Next, describe any indexes }. With IndexDefs do begin. Clear; { The 1st index has no name because it is. { a Paradox primary key }. With AddIndexDef do begin. Name := ''; Fields := 'Field1'; Options := [ixPrimary]; End; With AddIndexDef do begin. Name := 'Fld2Indx'; Fields := 'Field2'; Options := [ixCaseInsensitive]; End; End; { Call the CreateTable method to create the table }. CreateTable; End; End;

Изменение данных в таблице.

Теперь последний штрих о работе с таблицами. Мы разобрали способы обратиться к нужному столбцу и нужной записи, их поиск и чтение значений. А как записать новое значение? Для этого есть методы Edit, Append, Insert, Post и Cancel.

1) Надо изменить текущую запись.

Code: Table1.edit; //переводим таблицу в режим редактирования. Table1.fieldbyname('Category').asString:='New value';//изменяем поле. Table1.post;//сохраняем изменения.

Понятие о запросе (Query).

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

1) А если мне надо 1000 записей изменить, так мне надо в цикле крутить приведенный код? Так это ж как долго!

2) Ну хорошо, у меня есть табличка на сотню тысяч записей, и мне нужно из неё выбрать только, например, 1000 записей касательно "Иванова", так мне прийдётся всю таблицу в цикле крутить пока не найду то что мне нужно?

Все эти проблемы решены, и решены великолепно - просто, очень эффективно и с минимальными затратами.

Рассмотрим в кратце общий алгоритм доступа к информации который был рассмотрен:

1.1) Передать данные из таблицы в программу.

1.2) Программа сама занимается поиском данных.

А что если изменить схему:

2.1) Отдать команду драйверу на поиск нужной информации.

3.2) Драйвер найдёт инфу.

2.3) Найденная информация будет возвращена программе.

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

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

2) А если база данных находится на другом компьютере? Тогда программа вынуждена "вытащить" все данные на локальный компьютер перед манипулированием данными, что есть совсем не быстрая операция. Кстати пока мы тащим гигабайтную таблицу к себе, ваш сосед Вася уже успел там что-то поменять, и что теперь? Тащим заново, или посылаем Васю подальше, и не даём ему работать с базой пока сами не закончим?

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

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

Итак, из нашего тестового проекта удаляем компонент Table1. Вместо него ставим компонент TQuery. Устанавливаем Alias (DatabaseName) и связываем его с DataSource таким же образом как и таблицу.

Пока вы найдёте 2 радикальных отличия от TTable:

1) Нет свойства TableName.

2) Открытие (Active:=true) квери приводит к ошибке.

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

Code: Select * from biolife.

Теперь можно попытаться открыть квери (установить Active в True) и вы получите точно тоже что и в первом примере - грид заполненный данными из таблицы Biolife.db. Мало того, всё что мы проделывали с таблицей - позиционирование строки, чтение и запись полей и т.п. вы можете с успехом сделать и с Query - причём синтаксис тот же самый! Пока мы только сделали замену компоненту TTable и не более того.

Я здесь не буду подробно останавливаться на синтаксисе SQL запроса, материал по этой теме вы найдёте здесь:

Http://forum.vingrad.ru/index.php?act=ST&f=12&t=5638.

Однако простейшие приёмы работы я покажу. В нескольких дальнейших примерах мы будем менять свойство "SQL". Перед каждым изменением этого свойства Вы должны закрывать квери (в дизайне устанавливать Active в False). В run-time изменения SQL должны выглядеть примерно так:

Code: Query1.active:=false; Query1.sql.text:='Select * from biolife'; Query1.active:=true;

Запросы на выбор данных.

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

1) Выбор только тех строк (записей) которые отвечают условию (например тех где в поле category записано 'Snapper').

Code: SELECT * FROM biolife. Where category='Snapper'

Запросы на изменение данных.

А как менять значения в базе данных? Тоже при помощи квери это делать проще и, что важнее, значительно быстрее. Например, меняем в поле Category все "Cod" на "Kod". В квере пишем текст:

Code: Update biolife. Set Category='Kod' Where Category='Cod'

Всё о файлах (Статья).

Решил здесь собрать воедино основные приемы работы с файлами.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

©Drkb::03115.

Текстовые файлы.

Текстовый файл отличается тем что он разбит на разные по длине строки, отделенные символами #13#10. Есть 2 основных метода работы с текстовыми файлами - старый паскалевский способ и через файловые потоки. У обоих есть преимущества и недостатки. Через потоки способ проще поэтому начнем с него.

Итак у всех потомков класса TStrings (TStringList, memo.Lines и т.п. ) есть методы записи и чтения в файл - SaveToFile, LoadFromFile. Преимущество - простота использования и довольно высокая скорость, недостаток - читать и писать файл можно только целиком.

Примеры.

1) Загрузка текста из файла в Memo:

Memo1.lines.loadfromfile('c:\MyFile.txt');

2) Сохранение в файл:

Memo1.lines.savetoFile('c:\MyFile.txt');

3) А вот так можно прочитать весь файл в строку:

Code: Function ReadFromFile(FileName:string):string; Begin. With TStringList.create do. Try. LoadFromFile(FileName); Result:=text; Finally. Free; End; End;

Паскалевский метод доступа.

Для более тонких операций над текстовыми файлами прийдется освоить очень древний паскалевский способ.

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

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

1) Определяем файловую переменную:

Var f:TextFile;

2) Ассоциируем ее:

AssignFile(F, 'c:\MyFile.txt');

3) Теперь надо этот файл открыть, есть 3 варианта:

- файла нет или он должен быть перезаписан, открытие для записи:

Rewrite(f).

- файл есть и его надо открыть для чтения (с первой строки).

Reset(f).

- файл есть и его надо открыть для дописования строк в конец.

Append(f).

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

- Перезаписать весть файл.

- Читать с первой строки.

- Дописать что-то в конец.

- Читать и писать файл целиком (см. выше работу через TStrings).

В конце работы открытый файл нужно закрыть:

CloseFile(f);

Теперь пусть у нас есть строковая переменная s для чтения строки из файла.

Чтение предварительно открытого файла:

ReadLn(f, s) - будет прочитанна текущая строка и позиция чтения переведена на следующую позицию.

А как прочитать весь файл?

Code: While not eof(f) do. Begin. ReadLn(f, s); {здесь делаем что-то с прочитанной строкой}. End;

Не читаются русские буквы в Database Desktop.

Для DBD 7.0 нужно исправить реестр: ключ.

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\

SystemFont="Fixedsys".

Если такой ключ не существует, его следует создать.

Или.

[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage].

"1252"="c_1251.nls".

©Drkb::02493.

Автор: Pegas.

Взято с Vingrad.ru http://forum.vingrad.ru.

Подскажите пожалуйста, у меня вот какая проблема:

Загружаю Database Desktop, открываю таблицу имеющую в полях русский текст,

А отображается не русский текст а не понятно что.

О: MANka.

Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию.

[Properties].

SystemFont=Arial Cyr.

Для DBD 7.0 нужно исправить реестр: ключ.

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\

SystemFont="Fixedsys".

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

Все равно можно порекомендовать rx Database Explorer -- у него это получается очень хорошо.

О: Sergey V. Baldin.

Это - проблема русских .dbf и Dеsкtор'а . Надо установить шрифт.

По умолчанию не Arial Cyr , а Fixedsys или System. копать примерно так:

1.находишь производителя Desktop :

Например, если это Borland Desktop 7.0, то находишь строку в реестре.

HKEY_CURRENT_USER\SOFTWARE\BORLAND\DBD\7.0\Preferences\Properties\SystemFont и.

Меняешь Arial Cyr на стандартные для Windows: Fixedsys или System.

(писать название шрифта с большой буквы).

2. И в стандартном драйвере BDE ,например DBASE, ставишь русский драйвер dBASE RUS cp866.

Открываешь BDE configurator(administrator), ярлык на 32-BDE находится в панели управления.

И в строке Drivers->Native->DBASE->Langdriver->ставишь dBASE RUS cp866.

После этого все заиграет.

©Drkb::02494.

Взято с сайта http://blackman.wp-club.net/

Для DBD 5.0 в файл c:\windows\pdoxwin.ini.

Вставить в секцию.

[Properties].

SystemFont=Arial Cyr.

Для DBD 7.0 нужно исправить реестр: ключ.

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\

SystemFont="Fixedsys".

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

Copyright (C) Alexey Mahotkin 1997-1999.

©Drkb::02495.

Есть ли CD-ROM?

Code: GetLogicalDrives(). GetDriveType().

Как зарегистрировать базу данных (BDE)?

Code: Session.AddAlias(AliasName, AliasDriver, Params); Session.SaveConfigFile;

Возникает сложность копирования MS Access.

Говорит мол невозможно открыть файл. И на самом деле еще виден файл блокировки Access. Как закрыть базу так чтоб этот файл исчез и я мог сохранить.

Ответ:

Session.close.

©Drkb::02749.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как записать файл в Blob поле?

1)Через таблицу:

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. (table1.fieldbyname('ddd') as TBlobField).loadfromfile('dddss');

Как удалить данные из BLOB-поля?

Только с использованием SQL.

Code: UPDATE MyTable. Set MyBlobField = Null. WHERE SomeField = 'Somevalue'

Как в TBlobField загрузить картинку из переменной типа TBitmap?

1) LoadFromStream/SaveToStream.

2) TBlobField.assign.

©Drkb::02463.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как выделить кнопку в DBNavigator программно?

Code: Type TFake=class(TDBNavigator); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Procedure TForm1.Button1Click(Sender: TObject); Begin. TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONDOWN,0,0); TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONUP,0,0); End;

Ошибка совместного доступа к базе данных.

Подскажите как на дельфи создаются базы данных с которыми можно работать на нескольких компьютерах одновременно (таблицы Paradox). Как буфиризировать таблицы Paradox? Использую компонент DataBase со стандарным драйвером, указываю сетевой путь к БД, но при обращении сразу нескольких пользователей возникает сообщение что каталог заблокирован другим .NET файлом.

Решение:

Control Panel->BDE Administrator->закладка Configuration->Drivers->Native->Paradox.

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

©Drkb::02496.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как работать с полями типа DateTime?

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Query1.sql.text:='Select * From TableName Where (Date>:D1) and (Date<:D2)'; Query1.params.parsSql(Query1.sql.text, true); Query1.params.parambyname('d1').value:=Stringtodatetime('09.10.2002'); Query1.params.parambyname('d2').value:=Stringtodatetime('09.11.2002'); Query1.active:=true;

Доступ к Oracle через ADO.

Для доступа к данных хранящимся в Oracle лучше всего использовать не компоненты ADO а компоненты билиотека DAO (Data Access Oracle) с ними так же просто разобраться как и со стандартными компонентами, к тому же они работают на прямую с Oracle, без каких-либо посредников (например BDE, или тот же ODBC), и заточены соответственно под него. Линк точный дать не могу, но найти их будет не трудно (воспользуйся поисковой системой)...

Но если все же решил использовать ADO вот тебе строка:

1) способ если использовать "MS OLE DB Provaider for Oracle" - это провайдер мелкомягких.

Provider=MSDAORA.1;Password=USER123;User ID=USER;Data Source=MyDataSourse;

Persist Security Info=False.

2) способ если использовать "Oracle Provaider for Ole DB" - это провайдер от Oracle.

Provider=OraOLEDB.Oracle.1;Persist Security Info=False;User ID=USER;Data Source=MyDataSourse.

©Drkb::02720.

Автор: Pegas.

Взято с Vingrad.ru http://forum.vingrad.ru.

Почему я должен устанавливать BDE?

Есть один вопрос: как сделать так чтобы локальная база данных работала без бде администратор. В моем проекте база альясы не использует.

Типичная ошибка! BDE это не поддержка alias! компоненты Дельфи такие как Table, Query, Database - почти вообще ничего не делают! - это только удобный интерфейс к BDE. Т.е. BDE реально читает и пишет в базы данных, обнавляет файлы, управляет транзакциями, сортирует данные, исполняет SQL запросы. BDE с одной стороны имеет BDE Admin для ее управления, а с другой API, которые и использует Дельфи в компонентах. Если вам надо обойтись без BDE вы должны использовать другие драйвера доступа к базам данных: ODBC, DAO, ADO, RDO - многие из них имеют свои API или COM интерфейсы которые вы можете использовать (напрямую, либо найти компоненты для этого, кроме того ADO входит в стандартную поставку дельфей, но через него приконнектится к парадоксу довольно затруднительно). Если же все эти драйвера вас не устраивают то вам надо написать свой драйвер к базе данных (можно прямо в коде программы), он должен обеспечивать:

1) Чтение и запись базы.

2) Поддержка транзакций.

3) Исполнение SQL запросов.

4) Поддержка индексов и ключей.

5) Поддержка многопользовательского доступа.

6) Стандартный набор API которые позволят подключаться компонентам типа Table, Query.

Есть так же сторонние библиотеки для доступа к базам данных через свои собственные драйвера: HALCYON, или Апполо (Предложил МММ);

VkDBF- компонент для работы с ДБФ для Дельфы6/5 без БДЕ.(Предложил Free).

©Drkb::02484.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Допустим написал я программку для работы с некоторой базой данных, каким образом можно перетащить её на другой комп, если на нём нету никакого database desktop чтоб настроить Аliаs'ы, никаких библиотек нужных? Вы хотите сказать что никуда не деться и придётся заказчикам всем ставить с диска Delphi DB Desktop ?

Вы немного не понимаете архитектуру обращения к базе данных, BDE это вовсе не система настройки Аliаs'ов, не DB Desktop и не Database Administrator! Программа на Дельфи как и на любом другом языке общается с базами данных через особые драйвера баз данных, собственно компоненты ТТаь1у/ТQuеrу ничего не делают с базой данных, они только дают возможность в удобной форме послать запрос драйверу и интерпретировать ответ от драйвера, все запросы, все физические операции с базой данных делает вовсе не код вашего exe файла, а драйвер базы данных, который в данном случае входит в состав BDE. Примерно так же как когда вы сохраняете файл на диске вы же не даёте напрямую команду ВIОSу записать на диск номер такой-то дорожку такую-то сектор такой-то, вы пишете имя файла, а драйвер диска входящий в состав операционной системы сам знает в какие сектора что писать. Точно то же и с базами данных - существует драйвер, который физически работает с таблицами, а вы лишь пользуетесь компонентами, которые знают как работать с драйвером (не с базой данных!) и позволяют Вам это делать довольно удобным способом. Чтобы унифицировать работу и не иметь отдельного совершенно разного интерфейса к разным базам данных используют так называемые системы доступа к базам данных - это наборы драйверов ко всем более или менее распространённым базам данных, которые имеют более или менее стандартный интерфейс для программиста, единые программы их конфигурирования и единую идеологию построения. Одной из таких систем является BDE - Borland Database Engine - по русски, в дословном переводе - Борландовский движок для баз данных - заметьте, не конфигурация и не DB Desktop - а "движок", ядро, именно то что и обеспечивает работу с базами данных. Компоненты TTable/TQuery без BDE работать не будут - там просто нет тех API с которыми они оперируют. Физически BDE представляет из себя:

1) Файл хранящий настрйки.

2) Несколько DLL обеспечивающих общую работоспособность BDE.

3) Драйвера для различных баз данных (Paradox, MS SQL Server, InterBase и т.д.).

4) Служебные утилиты для конфигурации и простых операций с базами данных (DB Desktop, BDE Administrator).

5) SQL Link - система специальных драйверов для серверных баз данных с улучшенной архитектурой под приложения клиент-сервер.

Наличие файлов пунктов 1 и 2 - абсолютно необходимо, из пункта 3 - Вам в простейшем случае нужен лишь тот драйвер которым Вы пользуетесь. Файлы пунктов 4 и 5 - вспомогательные, для работоспособности BDE не имеют абсолютной необходимости.

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

©Drkb::02485.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

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

Как записать CDR/CDRW?

К сожалению, реальных примеров пока не найдено, а литература в сети крайне скудна по этому поводу. Вот список линков по которым удалось хоть что-то найти:

1) на torry есть компонент.

Http://www.torry.net/vcl/filedrv/cd/xpburn.zip (только для WindowsXP).

2)http://www.rsdn.ru/forum/Message.aspx?mid=81732&only=1.

3)http://www.micro-magic.com/cdrecording.html.

Убедительная просьба, если кто располагает информацией о записи на CD поделиться - бросить либо в форум, либо мне на почту.

©Drkb::01395.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как работать с ADO компонентами в DLL?

В оконных приложениях инициализацию COM берет на себя строка в файле проекта:

Application.Initialize;

А вот в DLL и консольных программах обэекта Application нет, и при попытке работать с любыми ActiveX, включая широко используемые ADO компоненты генерится ошибка, которую исправить очень просто: достаточно в секцию Uses в DPR файле добавить модуль oleauto.

©Drkb::02650.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как создать новый DSN из программы?

Code: Type. {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. TSQLConfigDataSource = Function(hwndParent: Integer; FRequest: Integer; LpszDriverString: string; LpszAttributes: string): Smallint; stdcall; Function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer; LpszDriverString: string; lpszAttributes: string): Integer; stdcall; Var. Func: TSQLConfigDataSource; OdbccpHMODULE: HMODULE; Begin. OdbccpHMODULE := LoadLibrary('c:\WINDOWS\SYSTEM\odbccp32.dll'); If OdbccpHMODULE = 0 then raise Exception.Create(SysErrorMessage(GetLastError)); Func := GetProcAddress(OdbccpHMODULE, PChar('SQLConfigDataSource')); If @func = nil then. Raise Exception.Create('Error Getting adress for SQLConfigDataSource' + SysErrorMessage(GetLastError)); Result := func(hwndParent, fRequest, lpszDriverString, lpszAttributes); FreeLibrary(OdbccpHMODULE); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If SQLConfigDataSource(0, 1, 'Microsoft Excel Driver (*.xls)', Format('DSN=%s;DBQ=%s;DriverID=790', ['MyDSNName', 'c:\temp\temp.xls'])) <> 1 then. ShowMessage('Cannot create ODBC alias'); End;

Создание новой MS Access базы данных.

Приведенная ниже процедура создает пустую базу данных MS Access.

Code: Procedure CreateMSAccessDatabase(filename: string); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var DAO: Variant; I: integer; Const Engines: array[0..2] of string = ('DAO.DBEngine.36', 'DAO.DBEngine.35', 'DAO.DBEngine'); Function CheckClass(OLEClassName: string): boolean; Var Res: HResult; Begin. Result := CoCreateInstance(ProgIDToClassID(OLEClassName), nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IDispatch, Res) = S_OK; End; Begin. For i := 0 to 2 do. If CheckClass(Engines[i]) then. Begin. DAO := CreateOleObject(Engines[i]); DAO.Workspaces[0].CreateDatabase(filename, ';LANGID=0x0409;CP=1252;COUNTRY=0', 32); Exit; End; Raise Exception.Create('DAO engine could not be initialized'); End;

Работа через WinAPI.

Раздел написан Podval (примеры к сожалению на С++).

Любителям WinAPI посвящается...

Функции FileOpen, FileSeek, FileRead.

Возьмем форму, положим на нее кнопку, грид и Опен диалог бокс.

Это для Билдера, но какая нам в данном случае разница?

Code: Void __fastcall TForm1::Button1Click(TObject *Sender). { Int iFileHandle; Int iFileLength; Int iBytesRead; Char *pszBuffer; If (OpenDialog1->Execute()). { Try. { IFileHandle = FileOpen(OpenDialog1->FileName, fmOpenRead); IFileLength = FileSeek(iFileHandle,0,2); FileSeek(iFileHandle,0,0); PszBuffer = new char[iFileLength+1]; IBytesRead = FileRead(iFileHandle, pszBuffer, iFileLength); FileClose(iFileHandle); For (int i=0;i<iBytesRead;i++). { StringGrid1->RowCount += 1; StringGrid1->Cells[1][i+1] = pszBuffer[i]; StringGrid1->Cells[2][i+1] = IntToStr((int)pszBuffer[i]); } Delete [] pszBuffer; } Catch(...). { Application->MessageBox("Can't perform one of the following file operations: Open, Seek, Read, Close.", "File Error", IDOK); } } }

Типизированные файлы.

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

Объявляем файл байтов:

Var f:file of byte;

B:Byte;

Ассоциируем файловую переменную с физическим файлом:

AssignFile(f,'c:\myfile.bin');

Теперь мы можем либо перезаписать/создать файл:

Rewrite(f);

Либо открыть существующий для чтения и записи:

Reset(f);

Обратите внимание, что функция Reset хотя и имеет такой же формат как и для текстовых файлов, но открытый ей файл можно и читать и писать, в отличие от текстовых.

Теперь функции работы с файлом:

Read(f,b); - прочитать 1 байт.

Write(f,b); - записать 1 байт.

Seek(f,100); - поставить текущее положение считывания/записи на сотый байт.

Size(f); - прочитать количество байт в файле.

Eof(f); - узнать не являетсмя ли байт последним.

Все эти функции не работают с файлами большими 2 Gb.

После работы файл надо закрыть:

CloseFile(f);

Приведенные выше механизмы будут работать с любым файлом, так как любой файл можно считать файлом байтов. Теперь где это можно использовать? В принципе везде, но в подавляющем большинстве случаев это будет очень неудобно, ведь скорость считывания при чтении по байтам будет на порядки более низкой чем другими способами. Однако в некоторых случаях этот способ может быть очень полезен. Например в программе вам надо заменить 100й байт файла на другой, или прочитать 100й байт файла, например во всяких читерских программах, при взломе и т.п. Здесь такой доступ будет весьма удобен. Гораздо более интересным представляется дальнейшее развитие технологии типизированных файлов (их еще лет 15 назад называли "Файлы прямого доступа"). Представим себе, что файл состоит не из байт а из более сложных структур. Например мы имеем некоторую информацию в виде:

Code: Type MyRec=Record. Name:string[100]; Age:byte; Membership:Boolean; Accounts:array[1..10] of integer; End;

Нетипизированные файлы.

Идем дальше. Есть такое понятие как нетипизированный файл. Это такой файл который содержит разнородные элементы. Например файл EXE - вначале он имеет заголовок, затем двоичный код, в конце какие-то ресурсы. Все части файла имеют разную длину и разную структуру. Тут уже обратится к произвольному элементу сложно, обычно надо вначале узнать где этот элемент находится, подчас это записано в предыдущем куске информации. Работа с такими файлами достаточно сложна и требует вручную разработки алгоритмов его чтения, но в связи гибкостью структуры и компактностью такие файлы составляют большинство. Для работы с нетипизированными файлами используют процедуры BlockRead и BlockWrite, которые позволяют читать/писать произвольное количество байт. Привожу пример пользования этими функциями из справки по Дельфи:

Code: Var. FromF, ToF: file; NumRead, NumWritten: Integer; Buf: array[1..2048] of Char; Begin. If OpenDialog1.Execute then { Display Open dialog box }. Begin. AssignFile(FromF, OpenDialog1.FileName); Reset(FromF, 1); { Record size = 1 }. If SaveDialog1.Execute then { Display Save dialog box}. Begin. AssignFile(ToF, SaveDialog1.FileName); { Open output file }. Rewrite(ToF, 1); { Record size = 1 }. Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF))+ ' bytes...'); Repeat. BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten); Until (NumRead = 0) or (NumWritten <> NumRead); CloseFile(FromF); CloseFile(ToF); End; End; End;

Файловые потоки.

Теперь разберем возможности работы потомка TStream - TFileStream - файловый поток. Этот класс был специально введен для работы с файлами. Для работы с файловым потоком Вам надо записать в Uses модули classes, Sysutils (classes - включает в себя собственно определение класса, Sysutils - некоторые константы необходимые для работы).

Вот пример записи/перезаписи файла:

Code: Procedure WriteFileUsingStream(s, FileName:string); Begin. With TFileStream.create(FileName, fmCreate or fmOpenWrite) do. Try. Write(pointer(s)^,length(s)); Finally. Free; End; End;

Работа через Handle.

Еще один способ работы с файлами - это открытие Handle на файл и работу через него. Тут есть 2 варианта - можно использовать функции Дельфи или использовать WinAPI напрямую.

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

FileOpen(FileName, fmOpenWrite or fmShareDenyNone) - функция открывает файл и возвращает целое цисло - Handle на файл. Параметры функции - имя файла и тип доступа (все типы доступа я перечислил ранее). Если файл успешно открыт то Handle должен быть положительным цислом, отрицательное число - это код ошибки.

Во всех остальных функциях используется именно значение Handle, возвращаемое этой функцией.

FileClose(Handle: Integer) - закрывает файл.

FileRead(Handle: Integer; var Buffer; Count: Integer): Integer;

FileWrite(Handle: Integer; const Buffer; Count: Integer): Integer;

Эти функции для чтения/записи файла, где Buffer любая переменная достаточного размера для чтения/записи куска информации (обычно типа PChar или массив), Count-количество байт, которое Вы желаете записать/прочитать. Функции возвращают количество байт которые реально были прочитанны или записаны.

Этот тип доступа к файлам применяется весьма редко. Дело в том что он практически дублирует соответствующие функции WinAPI и к тому же обычно работает несколько медленнее, чем например потоки. И все же использование функций FileOpen и FileClose не лишено привлекательности. Наряду с тем что эти функции намного легче в использовании соответствующих функций WinAPI (можете сравнить - FileOpen имеет 2 параметра, соответствующая функция WinAPI - CreateFile имеет 7 параметров, большая часть из которых реально требуется лишь в ограниченном числе случаев) этот путь доступа открывает возможность прямого использования всех функций WinAPI про работе с файлами, которые требуют Handle на открытый файл.

Файловые операции.

Дельфи предоставляет довольно широкие возможности по файловым операциям без использования механизмов открытия/закрытия файлов.

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

ChDir(NewCurrentPath: string); - изменяет текущий каталог (в среде Windows сие конечно не так актуально как в ДОС, но все же), прочитать же текущий каталог можно функцией GetCurrentDir, а текущий каталог для определенного драйва - GetDir.

CreateDir(const Dir: string): Boolean; - создает каталог. При этом предыдущий уровень должен присутствовать. Если вы хотите сразу создать всю вложенность каталогов используйте функцию ForceDirectories(Dir: string): Boolean; Обе функции возвращают True если каталог создан.

DiskFree(Drive: Byte): Int64; - дает свободное место на диске. Параметер - номер диска 0 = текущий, 1 = A, 2 = B, и так далее.

DiskSize(Drive: Byte): Int64; - размер винта. Обратите внимание на то что для результата этой и предыдущей функций абсолютно необходимо использовать переменную типа Int64, иначе макимум того что вы сможете прочитать правильно будет ограничен 2Gb.

FileExists(const FileName: string) - применяется для проверки наличия файла.

FileGetAttr(const FileName: string): Integer;

FileSetAttr(const FileName: string; Attr: Integer): Integer; - функции для работы с атрибутами файлов. Вот список возможных атрибутов:

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.

(Естественно не все атрибуты применимы во всех случаях).

RemoveDir(const Dir: string): Boolean; - удаляет папку(пустую).

DeleteFile(const FileName: string): Boolean; - удаляет файл.

RenameFile(const OldName, NewName: string) - переименовывает файл.

Информация о файле.

Привожу пример функции которая собирает довольно большое количество информации о выбранном файле:

Code: Type TFileInfo=record. Exists:boolean;//true если файл найден. Name:String; //имя файла с расширением. ShortName:String;//DOS 8.3 имя файла. NameNoExt:String;//имя файла без расширения. Extension:string;//расширение файла. AssociatedFile:string;//программа с которой ассоциирован файл. Path:string;// путь к файлу. ShortPath:string;// DOS 8.3 путь файла. Drive:string;// дисковод на котором находится файл. CreateDate:TDateTime; //время когда файл создан. Size:Int64;// размер файла (работает для файлов и больше 2Gb). Attributes:record //нали?ие/отсутствие системных атрибутов. ReadOnly:boolean; Hidden:boolean; System:boolean; Archive:boolean; End; ModifyDate:TDateTime; // время последнего изменения файла. LastAccessDate:TDateTime; // дата последнего открытия файла. End; Function ReadFileInfo(FileName:string):TFileInfo; Var ts:TSearchRec; Function FileTime2DateTime(FT:_FileTime):TDateTime; Var FileTime:_SystemTime; Begin. FileTimeToLocalFileTime(FT, FT); FileTimeToSystemTime(FT,FileTime); Result:=EncodeDate(FileTime.wYear, FileTime.wMonth, FileTime.wDay)+ EncodeTime(FileTime.wHour, FileTime.wMinute, FileTime.wSecond, FileTime.wMilliseconds); End; Function AssociatedFile(FileExt:string):string; Var key:string; Begin. With TRegistry.create do. Try. RootKey:=HKEY_CLASSES_ROOT; OpenKey(FileExt, false); Key:=ReadString(''); CloseKey; OpenKey(key+'\Shell\open\command', false); Result:=ReadString(''); Closekey; Finally. Free; End. End; Begin. Result.Name:=ExtractFileName(FileName); Result.Extension:=ExtractFileExt(FileName); Result.NameNoExt:=Copy(Result.Name,1,length(Result.Name)-length(Result.Extension)); Result.Path:=ExtractFilePath(FileName); Result.Drive:=ExtractFileDrive(FileName); Result.ShortPath:=ExtractShortPathName(ExtractFilePath(FileName)); If lowercase(Result.Extension)<>'.exe' then Result.AssociatedFile:=AssociatedFile(Result.Extension); If FindFirst(FileName, faAnyFile, ts)=0 then. Begin. Result.Exists:=true; Result.CreateDate:=FileDateToDateTime(ts.Time); Result.Size:=ts.FindData.nFileSizeHigh*4294967296+ts.FindData.nFileSizeLow; Result.Attributes.ReadOnly:=(faReadOnly and ts.Attr)>0; Result.Attributes.Hidden:=(faHidden and ts.Attr)>0; Result.Attributes.System:=(faSysFile and ts.Attr)>0; Result.Attributes.Archive:=(faArchive and ts.Attr)>0; Result.ModifyDate:=FileTime2DateTime(ts.FindData.ftLastWriteTime); Result.LastAccessDate:=FileTime2DateTime(ts.FindData.ftLastAccessTime); Result.ShortName:=ts.FindData.cAlternateFileName; Findclose(ts); End. Else. Result.Exists:=false; End;

Поиск файлов.

Теперь поговорим о поиске файлов. Для этой цели могут использоваться процедуры FindFirst, FindNext, FindClose, при участии переменной типа TSearchRec которая хранит информацию о текущем статусе поиска и характеристики последнего найденного файла.

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

Code: Var SearchRec:TSearchRec; ... If FindFirst('c:\Windows\*.*', faAnyFile, SearchRec)=0 then. Repeat. {Вот здесь мы можем делать с найденным файлом что угодно. SearchRec.name - имя файла. ExpandFileName(SearchRec.name) - имя файла с полным путем}. Until FindNext(SearchRec) <> 0; FindClose(SearchRec);

Проход дерева каталогов.

Code: Procedure ScanDir(Dir:string); Var SearchRec:TSearchRec; Begin. If Dir<>'' then if Dir[length(Dir)]<>'\' then Dir:=Dir+'\'; If FindFirst(Dir+'*.*', faAnyFile, SearchRec)=0 then. Repeat. If (SearchRec.name='.') or (SearchRec.name='..') then continue; If (SearchRec.Attr and faDirectory)<>0 then. ScanDir(Dir+SearchRec.name) //we found Directory: "Dir+SearchRec.name". Else. Showmessage(Dir+SearchRec.name); //we found File: "Dir+SearchRec.name". Until FindNext(SearchRec)<>0; FindClose(SearchRec); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ScanDir('c:'); End;

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

Сохранить файл в ресурсе программы на этапе компилляции можно выполнив следующие шаги:

1) Поставить себе RxLib.

2) Появится в меню "Project" дополнительный пункт меню "Resources".

3) Открой его , создай новый ресурс "User Data", в него загрузи нужный файл, измени имя ресурса на что-нибудь типа 'MyResName'.

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

Code: With TResourceStream.Create(hInstance, 'MyResName', RT_RCDATA) do. {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Try. Seek(0, soFromBeginning); SaveToFile('MyFileName.exe'); Finally. Free; End;

Удаление каталога с подкаталогами.

Способ 1: проход по дереву каталогов (Функция для удаления каталогов, взята из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..." - собственно код аналогичен написанному мной коду по рекурсивному проходу каталогов здесь).

Code: Function MyRemoveDir(sDir : String) : Boolean; Var. IIndex : Integer; SearchRec : TSearchRec; SFileName : String; Begin. Result := False; SDir := sDir + '\*.*'; IIndex := FindFirst(sDir, faAnyFile, SearchRec); While iIndex = 0 do. Begin. SFileName := ExtractFileDir(sDir)+'\'+SearchRec.Name; If SearchRec.Attr = faDirectory then. Begin. If (SearchRec.Name <> '' ) and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then MyRemoveDir(sFileName); End. Else. Begin. If SearchRec.Attr <> faArchive then FileSetAttr(sFileName, faArchive); If NOT DeleteFile(sFileName) then ShowMessage('Could NOT delete ' + sFileName); End; IIndex := FindNext(SearchRec); End; FindClose(SearchRec); RemoveDir(ExtractFileDir(sDir)); Result := True; End;

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

Code: Function FileVersion(AFileName:string): string; Var. SzName: array[0..255] of Char; P: Pointer; Value: Pointer; Len: UINT; GetTranslationString:string; FFileName: PChar; FValid:boolean; FSize: DWORD; FHandle: DWORD; FBuffer: PChar; Begin. Try. FFileName := StrPCopy(StrAlloc(Length(AFileName) + 1), AFileName); FValid := False; FSize := GetFileVersionInfoSize(FFileName, FHandle); If FSize > 0 then. Try. GetMem(FBuffer, FSize); FValid := GetFileVersionInfo(FFileName, FHandle, FSize, FBuffer); Except. FValid := False; Raise; End; Result := ''; If FValid then. VerQueryValue(FBuffer, '\VarFileInfo\Translation', p, Len). Else p := nil; If P <> nil then. GetTranslationString := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8); If FValid then. Begin. StrPCopy(szName, '\StringFileInfo\' + GetTranslationString + '\FileVersion'); If VerQueryValue(FBuffer, szName, Value, Len) then. Result := StrPas(PChar(Value)); End; Finally. Try. If FBuffer <> nil then FreeMem(FBuffer, FSize); Except. End; Try. StrDispose(FFileName); Except. End; End; End;

Сколько файлов есть в определённой папке?

Как наиболее быстрым способом узнать, сколько файлов с определенным расширением есть в определенной папке?

Например для HTM файлов:

Code: Function GetFileCount(Dir:string):integer; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var fs:TSearchRec; Begin. Result:=0; If FindFirst(Dir+'\*.htm',faAnyFile-faDirectory-faVolumeID, fs)=0 then. Repeat. Inc(Result); Until FindNext(fs)<>0; FindClose(fs); End;

Пример написания FileListBox.

1)WinAPI.

Code: {uses ShellApi}. Procedure TForm1.ListBox1DblClick(Sender: TObject); Var s:string; Begin. S:=listbox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)]; If edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\'); If (not FileExists(edit1.text+s)) and (s[1]='[')and(s[length(s)]=']') then. DlgDirList( handle, PChar(edit1.text+copy(s,2,length(s)-2)), ListBox1.Handle, Edit1.Handle, FaAnyFile. ); If edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\'); If FileExists(edit1.text+s) then. Begin. Caption:=edit1.text+s; ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show); End. End; Procedure TForm1.FormShow(Sender: TObject); Begin. Edit1.Width:=1024*8-1; Edit1.Visible:=false; DlgDirList(handle, PChar('c:\'), ListBox1.Handle, Edit1.Handle, FaAnyFile. ); Listbox1.Sorted:=false; Listbox1.Sorted:=true; End;

©Drkb::03181.

2).

Code: {uses ShellAPI}. Type PListBox=^TListBox; Procedure FillList(List:PListBox;pathh,mask:string;attr:Cardinal); Var path:string; Ser:TSearchRec; Begin. Path:=pathh; If path[length(path)]<>'\' then path:=path+'\'; List^.Items.Clear; If FindFirst(path+mask,attr,ser)<>0 then exit; List^.Items.Add(ser.Name); While FindNext(ser)=0 do. Begin. If ser.Attr and faDirectory=faDirectory then. List^.Items.Add(' ['+Ser.Name+']'). Else. List^.Items.Add(Ser.Name); End; List^.Sorted:=false; List^.Sorted:=true; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. FillList(@ListBox1,edit1.text,'*.*',faAnyFile); End; Procedure TForm1.ListBox1DblClick(Sender: TObject); Var s:string; Begin. S:=ListBox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)]; If (not FileExists(edit1.text+s)) and (s[1]+s[2]=' [') and (s[length(s)]=']') then. Begin. FillList(@ListBox1,edit1.text+copy(s,3,length(s)-3),'*.*',faAnyFile); Edit1.text:=edit1.text+copy(s,3,length(s)-3)+'\'; End; If FileExists(edit1.text+s) then. ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show); End;

Пример загрузки файлов в ListView с иконками.

Code: Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, comctrls, StdCtrls; Type. TForm1 = class(TForm). ListView1: TListView; Button1: TButton; Button2: TButton; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. Procedure SaveListViewToFile(AListView: TListView; sFileName: string); Procedure LoadListViewToFile(AListView: TListView; sFileName: string); Public. End; Const. Msg1 = 'File "%s" does not exist!'; Msg2 = '"%s" is not a ListView file!'; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string); Var. IdxItem, idxSub, IdxImage: Integer; F: TFileStream; PText: PChar; SText: string; W, ItemCount, SubCount: Word; MySignature: array [0..2] of Char; Begin. //Initialization. With AListView do. Begin. ItemCount := 0; SubCount := 0; //**** MySignature := 'LVF'; // ListViewFile. F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite); F.Write(MySignature, SizeOf(MySignature)); If Items.Count = 0 then. // List is empty. ItemCount := 0. Else. ItemCount := Items.Count; F.Write(ItemCount, SizeOf(ItemCount)); If Items.Count > 0 then. Begin. For idxItem := 1 to ItemCount do. Begin. With Items[idxItem - 1] do. Begin. //Save subitems count. If SubItems.Count = 0 then SubCount := 0 else SubCount := Subitems.Count; F.Write(SubCount, SizeOf(SubCount)); //Save ImageIndex. IdxImage := ImageIndex; F.Write(IdxImage, SizeOf(IdxImage)); //Save Caption. SText := Caption; W := Length(sText); PText := StrAlloc(Length(sText) + 1); StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w)); F.Write(pText^, w); StrDispose(pText); If SubCount > 0 then. Begin. For idxSub := 0 to SubItems.Count - 1 do. Begin. //Save Item's subitems. SText := SubItems[idxSub]; W := Length(sText); PText := StrAlloc(Length(sText) + 1); StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w)); F.Write(pText^, w); StrDispose(pText); End; End; End; End; End; F.Free; End; End; Procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string); Var. F: TFileStream; IdxItem, IdxSubItem, IdxImage: Integer; W, ItemCount, SubCount: Word; PText: PChar; PTemp: PChar; MySignature: array [0..2] of Char; SExeName: string; Begin. With AListView do. Begin. ItemCount := 0; SubCount := 0; SExeName := ExtractFileName(sFileName); If not FileExists(sFileName) then. Begin. MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error', MB_ICONERROR); Exit; End; F := TFileStream.Create(sFileName, fmOpenRead); F.Read(MySignature, SizeOf(MySignature)); If MySignature <> 'LVF' then. Begin. MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error', MB_ICONERROR); Exit; End; F.Read(ItemCount, SizeOf(ItemCount)); Items.Clear; For idxItem := 1 to ItemCount do. Begin. With Items.Add do. Begin. //Read imageindex. F.Read(SubCount, SizeOf(SubCount)); //Read imageindex. F.Read(IdxImage, SizeOf(IdxImage)); ImageIndex := IdxImage; //Read the Caption. F.Read(w, SizeOf(w)); PText := StrAlloc(w + 1); PTemp := StrAlloc(w + 1); F.Read(pTemp^, W); StrLCopy(pText, pTemp, W); Caption := StrPas(pText); StrDispose(pTemp); StrDispose(pText); If SubCount > 0 then. Begin. For idxSubItem := 1 to SubCount do. Begin. F.Read(w, SizeOf(w)); PText := StrAlloc(w + 1); PTemp := StrAlloc(w + 1); F.Read(pTemp^, W); StrLCopy(pText, pTemp, W); Items[idxItem - 1].SubItems.Add(StrPas(pText)); StrDispose(pTemp); StrDispose(pText); End; End; End; End; F.Free; End; End; // Example: Procedure TForm1.Button1Click(Sender: TObject); Begin. // Save Items and Clear the ListView. SaveListViewToFile(ListView1, 'MyListView.sav'); ListView1.Items.Clear; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // Load Items. LoadListViewToFile(ListView1, 'MyListView.sav'); End;

Как отслеживать изменение файла?

FindFirstChangeNotification, FindNextChangeNotification, FindCloseChangeNotification вместе с WaitForSingleObject.

Автор ответа: Baa.

©Drkb::03185.

Взято с Vingrad.ru http://forum.vingrad.ru.

Перетаскивание файлов в приложение.

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml.

Иногда очень полезно избавить пользователя от лишних операций при открытии файла.

Он должен нажать на кнопку " Открыть" , затем найти интересующий каталог, выбрать файл.

Проще перетащить мышкой файл сразу в окно приложения.

Рассмотрим пример перетаскивания Drag & Drop в окно произвольного текстового файла,

Который сразу же открывается в компоненте Memo1. Для начала в разделе Uses необходимо подключить модуль ShellAPI. В private области окна нужно вставить следующую строку:

Procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;//получение сообщений о переносе файла в окно приложения.

Процедура обработки этого сообщения будет выглядеть следующим образом:

Code: Procedure TForm1.WMDropFiles(var Msg: TWMDropFiles); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var. CFileName: array[0..MAX_PATH] of Char; // переменная, хранящая имя файла. Begin. Try. If DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH)> 0 then. // полу?ение пути файла. Begin. Form1.Caption:=CFileName; // имя файла в заголовок окна. Memo1.Lines.LoadFromFile(CFileName); // открываем файл. Msg.Result := 0; End; Finally. DragFinish(Msg.Drop); // отпустить файл. End; End;

Програмное выключение клавиатуры и мыши.

Code: Winexec(Pchar('rundll32 keyboard,disable' ) ,sw_Show); Клава OFF. Winexec(Pchar('rundll32 mouse,disable' ) ,sw_Show); Маус OFF.

Кстати а вот так клава врубается.

Отрубить.

Code: Asm. In al,21h. Or al,00000010b. Out 21h,al. End;

Врубить.

Code: Asm. In al,21h. Mov al,0. Out 21h,al. End;

©Drkb::01608.

Автор: Radmin.

Взято с Vingrad.ru http://forum.vingrad.ru.

BlockInput(), живёт в user32.dll.

©Drkb::01609.

Автор: Song.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как скрыть курсор мышки.

Поместите в событие OnClick в button1 и button2 следующие коды.Если курсор мышки скрыт, то выбрать button2 можно клавишей Tab.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowCursor(False); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. ShowCursor(True); End;

©Drkb::01610.

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

Code: //Выключение курсора. Procedure TForm1.Button1Click(Sender: TObject); Var. CState: Integer; Begin. CState := ShowCursor(True); While Cstate >= 0 do. Cstate := ShowCursor(False); End; //Включение курсора. Procedure TForm1.Button2Click(Sender: TObject); Var. Cstate: Integer; Begin. Cstate := ShowCursor(True); While CState < 0 do. CState := ShowCursor(True); End;

©Drkb::01611.

Взято с http://delphiworld.narod.ru.

Создание иконок из ресурсов.

Вот небольшая статейка, найденная мной в FAQ(http://blackman.km.ru/myfaq/cont4.phtml). Может пригодится?

Функция CreateIconFromResourceEx создает иконку или курсор из битов ресурса, описывающих иконку.

Перевод функции CreateIconFromResourceEx. CreateIconFromResourceEx Функция CreateIconFromResourceEx создает иконку или курсор из битов ресурса,

Описывающих иконку. HICON CreateIconFromResourceEx( PBYTE pbIconBits, // указатель на биты ресурса.

DWORD cbIconBits, // число бит в буфере.

BOOL fIcon, // флаг иконки или курсора.

DWORD dwVersion, // версия формата Windows.

Int cxDesired, // желаемая ширина иконки или курсора.

Int cyDesired, // желаемая высота иконки или курсора.

UINT uFlags.

); Параметры pbIconBits – указывает на буфер, содержащий биты ресурса иконки или курсора.

Эти биты обычно загружаются вызовами функций LookupIconIdFromDirectory (в Windows.

95 вы также можете использовать функцию LookupIconIdFromDirectoryEx) и LoadResource.

CbIconBits – определяет размер, в байтах, набора битов, на который указывает.

Параметр pbIconBits.

FIcon – определяет, будет ли создаваться иконка или курсор. Если значение этого.

Параметра равно TRUE, создается иконка. Иначе создается курсор.

DwVersion – определяет номер версии формата иконки или курсора для битов ресурса,

На которые указывает параметр pbIconBits. Параметр может принимать одно из следующих.

Значений: Формат Значение.

Windows 2.x 0x00020000.

Windows 3.x 0x00030000 Все Win32 приложения должны использовать для иконок и курсоров формат Windows.

3.x.

CxDesired – определяет желаемую ширину иконки или курсора в пикселях. Если значение.

Этого параметра равно нулю, функция использует значения метрики системы SM_CXICON.

Или SM_CXCURSOR для установки ширины.

CyDesired – определяет желаемую высоту иконки или курсора в пикселях. Если значение.

Этого параметра равно нулю, функция использует значения метрики системы SM_CXICON.

Или SM_CXCURSOR для установки высоты.

UFlags – определяет комбинацию из следующих значений: Значение Пояснение.

LR_DEFAULTCOLOR Используется цветовой формат по умолчанию.

LR_MONOCHROME Создается монохромная иконка или курсор. Возвращаемые значения В случае успеха возвращается дескриптор иконки или курсора.

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

Ошибке вызовите функцию GetLastError. Комментарии Функции CreateIconFromResourceEx, CreateIconFromResource, CreateIconIndirect,

GetIconInfo и LookupIconIdFromDirectoryEx позволяют приложениям оболочки и браузерам.

Иконок проверять и использовать ресурсы См. также BITMAPINFOHEADER, CreateIconFromResource, CreateIconIndirect, GetIconInfo, LoadResource,

LookupIconIdFromDirectoryEx . хелп по WinAPI: http://www.winnt.rsm.org.ru/winapi/win32api.exe

©Drkb::02354.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как использовать Shell API SHBrowseForFolder?

Статья из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи...".

Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?

Code: 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;

©Drkb::03187.

Источник: Дельфи. Вокруг да около.

Вариант от Анатолия (SAVwa@eleks.lviv.ua).

Code: Threadvar myDir: string; Function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): integer; stdcall; Begin. Result := 0; If uMsg = BFFM_INITIALIZED then begin. SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(myDir))). End; End; Function SelectDirectory(const Caption: string; const Root: WideString; Var Directory: string): Boolean; Var. WindowList: Pointer; BrowseInf! O: TBrowseInfo; Buffer: PChar; RootItemIDList, ItemIDList: PItemIDList; ShellMalloc: IMalloc; IDesktopFolder: IShellFolder; Eaten, Flags: LongWord; Begin. MyDir := Directory; Result := False; FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); If (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then. Begin. Buffer := ShellMalloc.Alloc(MAX_PATH); Try. RootItemIDList := nil; If Root <> '' then. Begin. SHGetDesktopFolder(IDesktopFolder); IDesktopFolder.ParseDisplayName(Application.Handle, nil, POleStr(Root), Eaten, RootItemIDList, Flags); End; With BrowseInfo do. Begin. HwndOwner := Application.Handle; PidlRoot := RootItemIDList; PszDisplayName := Buffer; Lpfn := @BrowseCallbackProc; LParam := Integer(PChar(Directory)); LpszTitle := PChar(Caption); UlFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or. BIF_STATUSTEXT; End; WindowList := DisableTaskWindows(0); Try. ItemIDList := ShBrowseForFolder(BrowseInfo); Finally. EnableTaskWindows(WindowList); End; Result := ItemIDList <> nil; If Result then. Begin. ShGetPathFromIDList(ItemIDList! , Buffer); ShellMalloc.Free(ItemIDList); Directory := Buffer; End; Finally. ShellMalloc.Free(Buffer); End; End; End;

Чтение из открытого файла.

Даже если файл открыт с низкими привелегиями (используя ReadOnly, ShareReadWrite) , иногда открытие уже открытого файла может приводить к ошибкам, особенно, если это файл интенсивно используется другим приложением. Самый простой способ решить эту проблемму - это использовать MemoryStream вместо непосредственного доступа к файлу:

Code: Var Memory: TMemoryStream; Begin. Memory := TMemoryStream.Create; Try. Memory.LoadFromFile('busyfile.dat'); // это он!! .. Memory.Read(...); // Вы можете использовать методы чтения как у файлов. Memory.Seek(...); FileSize := Memory.Size; .. Finally. Memory.Free; End; End;

Как найти путь к моей программе?

Application.ExeName.

Автор ответа: Baa.

©Drkb::03157.

Взято с Vingrad.ru http://forum.vingrad.ru.

Или еще лучше Paramstr(0) - лучше потому что работает и без объекта Application и в DLL.

©Drkb::03158.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как удалить файл после перезагрузки Windows?

Я использую функцию, которая заносит в ключ реестра RunOnce командную строку:

Command.com /c del C:\Путь\Имя_файла.

Автор ответа: inko.

©Drkb::03169.

Взято с Vingrad.ru http://forum.vingrad.ru.

В wininit добавляешь строку NUL={ПУТЬ УДАЛЯЕМОГО ФАЙЛА}.

Автор ответа: VoL.

©Drkb::03170.

Взято с Vingrad.ru http://forum.vingrad.ru.

Еще есть способ через реестр:

Code: Uses Registry; {©Drkb v.3(2007): www.drkb.ru}. Procedure DeleteFileOnRestart (const FileName : String); Var Reg : TRegistry; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey ('Software\Microsoft\Windows\CurrentVersion\RunOnce', False); Reg.WriteString ('Selfdel9x','command.com /C del "' + FileName + '"'); Reg.WriteString ('SelfdelNT','cmd /C del "' + FileName + '"'); Reg.CloseKey; Reg.Free; End;

Как поместить в буфер файл с помощью File Mapping?

1.

В файлике Delphi5\Demos\Resxplor\exeimage.pas ищи слово CreateFileMapping.

2.

Идея простая открываешь файл .. (или создаешь).

Создаешь Mapping ... CreateFileMapping.

Отображаешь Mapping в свой процесс MapViewOfFile.

И всё.

Code: Var. SharedHandle: THandle; FileView: Pointer; MyFile: HFILE; Begin. MyFile := OpenFile('c:\1.txt', // pointer to filename. ..., // pointer to buffer for file information. ... // action and attributes. ); SharedHandle := CreateFileMapping(MyFile, nil, PAGE_READWRITE, 0, Size {размер файла}, PChar('MyFile')); FileView := MapViewOfFile(SharedHandle, FILE_MAP_WRITE, 0, 0, size {размер файла}); ... ... ... ... // потом. UnmapViewOfFile(FileView);

Как удалить файл из самого себя?

Очевидно что под Win32 удаление работающего кода невозможно. На время выполнения он просто добавляется к swap файлу - т.е. винды при нехватки памяти данные программы (массив переменных) сбрасывают в Swap (Page) файл, а сам код программы просто уничтожается из памяти, при возобновлении процесса, недостающие куски кода опять считываются из исходного файла. Понятно, что изменение файла пока его код выполняется будет иметь катастрофичные последствия, поэтому винды при запуске программы считают DLL или EXE файл по сути куском файла подкачки и запрещают любые манипуляции над ним. Кстати именно по этой причине все инсталляторы начинают свою работу с операции "Preparing to install", которая делает очень простую вещь - сам инсталлятор копируется во временную папку и перезапускает себя уже с винта, чтоб предотвратить крах системы при смене дискетты или CD. По этой же причине программы упакованные любыми EXE упаковщиками требуют больше памяти для запуска - так как загружается в память и исходный компрессированный код и декомпрессированный поток... Но несмотря на все сказанное можно удалить файл из "самого себя" при помощи маленькой хитрости: мы создаем и запускаем BAT файл - который и удалит программу, а саму программу закрываем, как только система "отпустит" файл - файл будет удален и затем BAT файл удалит самого себя. Пользователь всего этого не заметит - он увидит, что после завершении работы файла программы уже нет.

Code: Uses ShellApi; Procedure TForm1.FormDestroy(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var f: textFile; FileName: string; Begin. FileName := changefileext(paramstr(0), '.bat'); AssignFile(f, FileName); Rewrite(f); Writeln(f, ':1'); Writeln(f, format('Erase "%s"', [paramstr(0)])); Writeln(f, format('If exist "%s" Goto 1', [paramstr(0)])); Writeln(f, format('Erase "%s"', [FileName])); Closefile(f); ShellExecute(Handle, 'Open', PChar(FileName), nil, nil, sw_hide); End;

Как создать ShortCut файл (.LNK)?

Code: Uses ShlObj, ActiveX, ComObj; ... {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Procedure CreateShortCut(ShortCutName, Parameters, FileName: string); Var ShellObject: IUnknown; ShellLink: IShellLink; PersistFile: IPersistFile; FName: WideString; Begin. ShellObject := CreateComObject(CLSID_ShellLink); ShellLink := ShellObject as IShellLink; PersistFile := ShellObject as IPersistFile; With ShellLink do. Begin. SetArguments(PChar(Parameters)); SetPath(PChar(FileName)); SetWorkingDirectory(PChar(extractfilepath(FileName))); FName := ShortCutName; PersistFile.Save(PWChar(FName), False); End; End;

Как оперделить все IP и порты на моем компьютере?

Функции GetTcpTable, GetUdpTable.

Импорт GetTcpTable:

Code: Unit TcpTable; Interface. Type. PDWord = ^Longword; PMIB_TCPROW = ^TMIB_TCPROW; TMIB_TCPROW = record. DwState: LongWord; DwLocalAddr: LongWord; DwLocalPort: LongWord; DwRemoteAddr: LongWord; DwRemotePort: LongWord; End; PMIB_TCPTABLE = ^TMIB_TCPTABLE; TMIB_TCPTABLE = record. DwNumEntries: LongWord; Table: array[0..0] of TMIB_TCPROW; End; Function GetTcpTable(var TcpTable: PMIB_TCPTABLE; var Size: PDWord; bOrder: Boolean): LongWord; stdcall. Implementation. Function GetTcpTable; external 'Iphlpapi.dll' name 'GetTcpTable'; End.

BASM - Уроки для начинающих

BASM.

Уроки для начинающих.

Денис Христенсен.

Из news://forums.borland.com.

Borland.public.Delphi.languages.basm.

© Dennis Chistensen, 2003.

© Anatoly Podgoretsky, 2003, Russian translations.

Vit - Печатается в DRKB с сокращениями.

©Drkb::00301.

Введение.

Серия статей, названная “BASM for beginners” (BASM уроки для начинающих) в данный момент состоит из 7 статей, статьи 8 и 9 находятся в стадии подготовки. Общее для этих статей и для тех, что в процессе подготовки то, что они объясняют некоторые вопросы использования BASM на примерах функций. Большинство из этих функций сначала реализуются на Паскале, затем сгенерированный компилятором ассемблерный код, копируется из окна CPU view в Delphi, затем анализируется и оптимизируется. Иногда оптимизация включает в себя и использование инструкций MMX, SSE или SSE2.

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

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

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

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

С уважением,

Денис Христенсен Dennis Kjaer Christensen.

Lesson 1.

Начнем с небольшого примера. Это простая функция Паскаля по умножению целого на константу 2.

Code: Function MulInt2(I : Integer) : Integer; Begin. Result := I * 2; End;

BCD --> String.

Code: Function BCDToNumString(const inStr: string): string; Procedure UnPack(ch: Char; var ch1, ch2: Char); Begin. Ch1 := Chr((Ord(ch) and $F) + $30); Ch2 := Chr(((Ord(ch) shr 4) and $F) + $30); Assert((ch1 >= '0') and (ch1 <= '9')); Assert((ch2 >= '0') and (ch2 <= '9')); End; Var. I: Integer; Begin. SetLength(Result, Length(inStr) * 2); For i := 1 to Length(inStr) do. UnPack(inStr[i], Result[2 * i - 1], Result[2 * i]); End; Procedure TForm1.Button1Click(Sender: TObject); Var. S1, S2: string; Begin. S1 := '15151515151515151515'; S2 := NumStringToBCD(S1); Memo1.lines.add('S1: ' + S1); Memo1.lines.add('Length(S2): ' + IntToStr(Length(S2))); Memo1.lines.add('S2 unpacked again: ' + BCDToNumString(S2)); End;

Berkeley DB.

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

Введение.

Berkeley Database (Berkeley DB) – встроенная система баз данных, которую можно использовать в приложениях, нуждающихся в высокопроизводительном механизме хранения и извлечения пар ключ-значение, поддерживающем одновременный доступ. Программный продукт распространяется в виде библиотеки, которая может быть подключена к коду приложения. Функции библиотеки доступны через ряд API-интерфейсов, в том числе для языков Си, C++, Java, Perl, Python и Tcl. Загрузить Berkeley DB можно с Web-сайта Sleepycat Software по адресу www.sleepycat.com.

Sleepycat распространяет Berkeley DB, как программный продукт с открытым кодом. Компания предусматривает лицензионные отчисления за определенные виды использования ПО, а также взимает плату за поддержку и услуги.

История.

Berkeley DB зародилась, как новая реализация метода доступа hash, созданного взамен hsearch и различных вариантов dbm (а именно, dbm корпорации AT&T, ndbm от Berkeley и gdbm, разрабатывавшегося в рамках проекта GNU). Продукт был разработан и выпущен под названием Hash в 1990 году программистами Зельцер и Йигит [8].

В первой крупной редакции Berkeley DB, вышедшей в 1991 году, были внесены некоторые изменения в пользовательский интерфейс и добавлен новый метод доступа, B+tree. Примерно в то же время Зельтцер и Олсон разработали прототип транзакционной системы на основе Berkeley DB под названием LIBTP [9], код которой не публиковался.

В 1992 году Berkeley DB 1.85 была включена в состав операционной системы 4.4BSD UNIX. В начале 90-х Зельцер и Бостик сопровождали код в Беркли и Массачусетсе. В то время он получил широкое распространение среди пользователей.

К середине 1996 года появились пользователи, нуждающиеся в коммерческой поддержке продукта. Учтя их пожелания, Бостик и Зельтцер образовали компанию Sleepycat Software. Она совершенствует, распространяет и поддерживает Berkeley DB, а также сопутствующее программное обеспечение и документацию. В середине 1997 года Sleepycat выпустила Berkeley DB 2.1, содержащую ряд важных новшеств, в том числе возможность многопользовательского доступа к базам данных. Компания выпускает около трех коммерческих версий продукта в год. Последняя выпущенная ею версия Berkeley DB имеет номер 3.1.

Краткий обзор Berkeley DB.

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

Интерфейсы для C++ и Java реализуют небольшой набор классов для работы с базами данных. Корневой класс в обоих языках носит название Db – он содержит методы, инкапсулирующие упомянутые выше интерфейсы dbm-стиля.

Имеются также интерфейсы для работы с Berkeley DB при помощи языков сценариев Perl, Python и Tcl.

Berkeley DB можно подключать к коду приложения динамически или статически.

Использование Berkeley DB.

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

На наш взгляд, Berkeley DB проще в понимании и обращении, чем автономные СУБД. Она хранит и извлекает записи, состоящие из пар ключ-значение. Ключи используются для обнаружения элементов и могут представлять собой данные любого типа или любые структуры, поддерживаемые применяемым языком программирования.

Программист может указать Berkeley DB использовать написанные им самим функции выполнения операций над ключами. Например, метод доступа B+tree может использовать произвольную функцию сравнения, а Hash – произвольную хэш-функцию. Если пользовательские функции не определены, Berkeley DB использует собственные. В противном случае система вообще не просматривает и не интерпретирует ключи и значения. Значения могут быть произвольной длины.

Важно понимать, чем Berkeley DB не является. Berkeley DB – не сервер баз данных, обрабатывающий запросы, поступающие по сети. Это также не SQL-ядро, выполняющее запросы. Не является Berkeley DB и реляционной или объектно-ориентированной СУБД.

Все перечисленные системы можно построить поверх Berkeley DB, которая сама по себе является всего лишь встраиваемым механизмом баз данных. Разработчики постарались сделать его переносимым, компактным, быстрым и надежным.

Приложения, использующие Berkeley DB.

Система Berkeley DB встроена в ряд продуктов, как с открытым кодом, так и коммерческих. В данном разделе перечислены некоторые из них.

Серверы каталогов, хранящие и извлекающие данные с применением протокола каталогов LDAP, а также реализующие службу именования и поиска по каталогам в локальных сетях. Основа этой службы – опрос и обновление базы данных, но с применением простого протокола, а не SQL или ODBC. Berkeley DB выполняет функции встроенного диспетчера данных в большинстве существующих серверов каталогов, включая LDAP-серверы компаний Netscape, MessagingDirect и других.

Berkeley DB встроена в большое число почтовых серверов. Intermail компании Software.com использует Berkeley DB в качестве хранилища сообщений и в качестве основного хранилища для своего сервера каталогов. Сервер sendmail (как коммерческий Sendmail Pro компании Sendmail, так и версия, распространяемая через sendmail.org) использует Berkeley DB для хранения псевдонимов и другой информации. Postfix (ранее носивший название VMailer) также использует Berkeley DB для хранения административной информации.

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

Berkeley DB также входит в состав многих программ с открытым кодом, распространяемых по Internet. В частности, система встроена в Web-сервер Apache и в графическую оболочку Gnome. Все коммерческие дистрибутивы Linux, а также многие разновидности BSD содержат Berkeley DB.

Методы доступа.

В терминологии баз данных метод доступа — это совокупность размещаемой на диске структуры, используемой для хранения данных и операций над этой структурой. Например, многие системы баз данных поддерживают метод доступа B+tree. Он позволяет производить поиск по точному соответствию («найти ключи, равные некоторой константе»), поиск интервала («найти ключи, попадающие в интервал между двумя константами»), а также вставку и удаление записи.

Berkeley DB поддерживает четыре метода доступа: B+tree, Persistent Queues (Queue), Extended Linear Hashing (Hash) и Fixed- or Variable-length Records (Recno). В методах B+tree и Hash ключи могут иметь произвольную структуру. В методах доступа Queue и Recno каждой записи присваивается номер, который и служит ключом. Во всех методах доступа значение может иметь произвольную структуру. Если программист подставляет собственные функции сравнения или хэширования, Berkeley DB хранит и извлекает значения, не интерпретируя их.

В качестве основного хранилища все методы доступа используют файловую систему ОС.

Hash.

Berkeley DB поддерживает метод доступа Hash, реализующий расширяемую линейную хэш-таблицу [4]. Особенность такого хэширования в том, что хэш-функция адаптируется по мере роста таблицы, и все хэш-корзины в устойчивом состоянии по мере возможности остаются заполненными не до конца.

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

B+tree.

Berkeley DB поддерживает метод доступа B+tree [1]. B+деревья хранят пары ключ-значение в листовых страницах, а пары «ключ, адрес дочерней страницы» – на внутренних узлах. Ключи в дереве хранятся в отсортированном порядке, заданном функцией сравнения, указанной при создании базы данных. Для упрощения задачи обхода дерева страницы на листовом уровне содержат указатели на соседей. B+tree поддерживает поиск по точному соответствию (равенству) или интервалу (допустимы лишь интервалы «больше или равно»). Как и хэш-таблицы, B+деревья поддерживают вставку, удаление и повторение всех записей в дереве.

По мере заполнения записями страниц они разбиваются – примерно половина ключей уходит на новую страницу, находящуюся на том же уровне дерева. Большинство реализаций В+дерева после деления оставляют оба узла заполненными наполовину. В общем случае это приводит к снижению производительности, когда вызывающий вставляет ключи по порядку. Но Berkeley DB запоминает порядок вставки и разбивает страницы не поровну, а таким образом, чтобы они заполнялись более, чем наполовину. Благодаря этому уменьшается размер дерева и общий объем базы данных, повышается производительность поиска.

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

Queue.

Berkeley DB реализует метод доступа, управляющий высокопроизводительными долговременными очередями. Он построен на базе метода доступа B+tree, но использует механизмы блокировки и протоколирования, необходимые для работы в условиях интенсивного многопользовательского доступа к голове и хвосту очереди. Процесс обновления головы или хвоста очереди блокирует другие потоки на протяжении не всей транзакции, а лишь на время своего выполнения. Благодаря этому качество поддержки параллельного выполнения транзакций значительно улучшается.

Recno.

Berkeley DB содержит метод доступа к записям фиксированной или переменной длины под названием Recno. Он присваивает каждой из записей логический номер, по которому может осуществляться поиск и обновление. Recno может, например, загрузить в базу данных текстовый файл, рассматривая каждую строку в качестве записи. Используя эту возможность, в текстовых редакторах можно производить быстрый поиск по номеру строки [10].

Recno построен на базе метода доступа В+tree и предоставляет простой интерфейс для хранения значений, упорядоченных по номеру. Recno генерирует номера записей самостоятельно. С точки зрения программиста значения нумеруются последовательно, начиная с единицы. Разработчик может указать системе, должны ли записи автоматически перенумеровываться после добавления или удаления записей с меньшими номерами. Если да, то новые ключи можно будет вставлять между существующими.

Особенности.

В данном разделе описываются важнейшие особенности Berkeley DB. Разработчик имеет возможность использовать в своем приложении только необходимые ему функции системы.

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

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

Интерфейсы программирования.

Berkeley DB предоставляет простой API-интерфейс для управления базами данных. В комплект поставки программного обеспечения не входят стандартные интерфейсы типа ODBC, OLEDB или SQL. Эти интерфейсы весьма удобны, однако они создавались с целью обеспечения интероперабельности систем баз данных, но не простоты или высокой производительности.

Идя навстречу пожеланиям пользователей, создатели Berkeley DB в версии 2.5 реализовали поддержку стандарта XA [5]. XA позволяет Berkeley DB принимать участие в распределенных транзакциях под управлением монитора обработки транзакций, подобного Tuxedo компании BEA Systems. Подобно XA, поверх ядра системы можно построить и другие стандартные интерфейсы. Стандарты не являются частью внутреннего механизма Berkeley DB, так как в их поддержке нуждаются не все приложения.

Работа с записями.

Пользователю базы данных может понадобиться произвести поиск определенных ключей или просто просмотреть имеющиеся записи. Berkeley DB поддерживает как доступ по ключам, т. е. возможность найти все записи с заданным ключом, так и последовательный доступ – возможность извлечь сразу все записи базы данных. Порядок, в котором возвращаются записи, зависит от метода доступа. Базы данных в форматах В+tree и Recno возвращают записи в порядке сортировки, а Hash-базы – в случайном порядке.

В Berkeley DB предусмотрены также простые интерфейсы для вставки, обновления и удаления записей в базе данных.

Длинные ключи и значения.

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

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

Крупные базы данных.

Максимальный размер базы данных, поддерживаемый Berkeley DB, составляет 248 байт или 256 Тбайт. Поскольку Berkeley DB использует в качестве основного хранилища базы данных файловую систему ОС, она должна поддерживать работу с файлами больших размеров. У Sleepycat Software есть клиенты, пользующиеся Berkeley DB для управления базами данных, размер которых превышает 1 Тбайт.

Базы данных, размещаемые в основной памяти.

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

Существуют приложения, нуждающиеся в дисковом пространстве для основного хранилища, но работающие на системах с очень большим объемом памяти. Berkeley DB может выполнять роль диспетчера очень больших участков памяти, совместно используемой для управления блокированием, хранения кэшированных страниц данных и записей протокола. Например, участок, используемый для кэширования страниц данных, может иметь размеры в несколько гигабайт – таким образом уменьшается вероятность того, что при операции чтения в устойчивом состоянии потребуется доступ к диску. Размер кэш-региона декларируется при старте программы.

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

Определяемый размер страниц.

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

Компактность.

– компактная система. Двоичные файлы полного комплекта, в том числе всех методов доступа, механизмов восстановления и транзакций, занимают на стандартных архитектурах около 200 Кбайт.

Курсоры.

В терминологии СУБД курсор – это указатель на метод доступа, который циклически вызывается для последовательного возвращения записей. В Berkeley DB имеются курсорные интерфейсы для всех методов доступа. Применение курсоров позволяет, например, обойти В+дерево, просматривая записи в порядке обхода. Указатели на записи в курсорах являются долговременными, так что будучи захваченной один раз, запись может быть впоследствии обновлена на прежнем месте. Кроме того, курсоры позволяют работать с цепочками повторяющихся данных в различных методах доступа.

Соединения.

В терминологии СУБД соединение это операция, объединяющая несколько таблиц (или в случае с Berkeley DB, несколько файлов баз данных) в одну. Приведем пример: компания хранит сведения о своих клиентах в одной таблице, а информацию о сбыте – в другой. Допустим, приложению понадобилось просмотреть данные о сбыте по именам клиентов; это потребует приведения в соответствие записей в двух таблицах, имеющих общее поле «имя покупателя». Такое объединение записей из двух таблиц называется соединением.

Berkeley DB содержит интерфейсы для соединения двух или более таблиц.

Транзакции.

Транзакция обладает четырьмя свойствами [2].

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

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

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

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

Сочетание свойств атомарности, согласованности, изолированности и долговечности обычно обозначают сокращением ACID (atomicity, consistency, isolation, durability). Berkeley DB, как и большинство систем баз данных, обеспечивает ACID за счет набора базовых служб.

Программисты могут пользоваться поддержкой транзакций Berkeley DB при необходимости.

Протоколирование с упреждением.

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

В любой точке процесса выполнения транзакции приложение может подтвердить ее результаты (commit), сделав изменения перманентными, или откатить (roll back), отменив все изменения и восстановив базу данных до состояния перед началом транзакции. Если приложение откатывает транзакцию, протокол будет содержать состояние всех измененных страниц до начала транзакции, и Berkeley DB просто восстановит базу данных до этого состояния. Если приложение завершает транзакцию, Berkeley DB сохраняет записи протокола на диск. Копии страниц данных, находящиеся в памяти, уже содержат внесенные изменения и будут сброшены на диск установленным порядком в ходе нормальной обработки. Тем самым повышается производительность, поскольку протокол ведется последовательно, а запись в страницы данных происходит в случайной последовательности.

Сбои и восстановление.

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

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

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

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

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

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

Контрольные точки.

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

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

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

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

Двухфазная блокировка.

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

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

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

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

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

Механизм двухфазной блокировки построен на самых быстрых примитивах корректного блокирования, поддерживаемых архитектурой нижнего уровня. Это означает, что для каждой из Unix-платформ система блокировки реализована в последней версии Berkeley DB по-разному, не говоря уже о реализации для Windows NT. Как показывает наш опыт, самыми сложными этапами оптимизации производительности является поиск наиболее быстрых примитивов блокирования, корректно работающих на конкретной архитектуре, и интеграция нового интерфейса с уже существующими.

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

Параллелизм.

Хорошая производительность при параллельных операциях – одна из важнейших целей, которые ставили разработчики при создании Berkeley DB. Хотя сама по себе Berkeley DB не является многопоточной, она корректно работает в приложениях, использующих потоки. Мы считаем, что решение об использовании потоков и выборе механизма их реализации должны приниматься разработчиком, и поэтому предпочли реализовать механизм (возможность потокового или обычного выполнения), позволяющий приложению поступать сообразно своим потребностям.

Подсистемы блокировки, протоколирования и управления буферным пулом для обмена информацией используют совместный доступ к памяти или другие имеющиеся в от ОС функции совместного доступа. Блокировки, захваты буферных пулов и операции записи в протокол одинаково ведут себя, работая в потоках, в едином процессе и в разных процессах, выполняющихся на одной машине.

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

Berkeley DB была тщательно спроектирована таким образом, чтобы минимизировать конфликты и обеспечить максимальный параллелизм. Диспетчер кэша позволяет всем потокам или процессам пользоваться операциями ввода-вывода, выполняемыми одним из них. Совместно используемые ресурсы иногда необходимо блокировать для предоставления эксклюзивного доступа одному управляющему потоку. Мы позаботились о том, чтобы важнейшие функции Berkeley DB были небольшими по объему и чтобы в ходе системных вызовов блоки критических ресурсов не удерживались слишком долго, чтобы создать препятствие для блокирующего потока или процесса. У Sleepycat Software есть клиенты, у которых с одной базой данных параллельно работают сотни пользователей.

Философия проектирования.

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

Свои преимущества Berkeley DB получила благодаря тому пристальному вниманию, которое уделялось деталям проектирования на протяжении всего существования программного продукта. Мы позаботились о том, чтобы ключевые функции, такие как блокировка и ввод/вывод либо были доступными через удобные интерфейсы, либо работали прозрачно для вызывающего. Будучи программистами, мы понимаем ценность простоты и много работали над упрощением интерфейсов, через которые пользователь обращается к системе баз данных.

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

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

В архитектуре и реализации Berkeley DB нет никаких новшеств. Проектируя систему, мы старались как можно лучше реализовать традиционные подходы. В результате получилась встроенная система баз данных, превосходящая сходные решения по качеству.

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

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

Распространение Berkeley DB 3.x.

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

Состав дистрибутива.

Дистрибутив представляет собой заархивированный файл. Он содержит исходный текст библиотеки Berkeley DB, документацию, тестовые комплекты и утилиты сопровождения.

Исходный текст содержит директивы компиляции для всех поддерживаемых платформ. В Unix для идентификации разновидности ОС, сборки библиотеки и утилит Berkeley DB использует распространяемый на условиях лицензии GNU инструмент автоконфигурирования autoconf. Berkeley DB содержит директивы сборки и для других платформ, в том числе для ОС реального времени VxWorks, а также Windows 95/98/NT/2000.

Документация.

Документация поставляется в формате HTML. Она состоит из двух частей – руководство в традиционном для Unix стиле для программистов и справочное руководство, составленное по принципу учебника.

Тестовый комплект.

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

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

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

Двоичный дистрибутив.

Sleepycat предоставляет заказчикам скомпилированные библиотеки и полноценные двоичные дистрибутивы за деньги.

Поддерживаемые платформы.

Berkeley DB работает на любой операционной системе с интерфейсом POSIX 1003.1 [3], который имеется практически во всех разновидностях Linux и Unix. Кроме того, программный продукт работает в среде ОС реального времени VxWorks компании Wind River Systems, а также на VMS, Windows 95, Windows 98, Windows NT и Windows 2000.

Лицензирование Berkeley DB 3.x.

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

Berkeley DB версий 1.х сопровождалась лицензией UC Berkeley, которая позволяла свободно распространять наше ПО в исходных текстах. После создания Sleepy Software нам потребовалось было разработать новую лицензию, согласующуюся с предыдущей. Ввиду серьезных отличий UC Berkeley от GPL мы не могли просто использовать последнюю. Создание новой лицензии, условия которой противоречили бы первой, означал бы отказ от прежних принципов.

По ряду причин Sleepycat намеревалась продолжать разработку Berkeley DB по принципу открытого кода. Мы согласны с Эриком Рэймондом [7] и другими в том, что ПО с открытым кодом, как правило, отличается от собственнических продуктов, распространяемых только в двоичном виде, более высоким качеством. Наши клиенты пользуются услугами сообщества разработчиков, хорошо знающих Berkeley DB, и способных помочь в проектировании, отладке приложения и оптимизации его производительности. Благодаря широкому распространению исходного текста ошибки обычно выявляются уже на ранних этапах, и исправления вносятся весьма оперативно. Таким образом обеспечивается высокая надежность Berkeley DB. Открытый, бесплатно распространяемый код дает и преимущества с точки зрения бизнеса. Мы имеем и прибыль, и рынок сбыта для своих продуктов и услуг. Кроме того, доступность исходных текстов сокращает нагрузку на нашу службу поддержки, поскольку во многих случаях клиенты могут самостоятельно находить и исправлять ошибки, не обращаясь к нам.

Новая лицензия, контролирующая Berkeley DB 2.x и 3.х, сохраняет принципы распространения кода предыдущих версий системы. Мы позаимствовали из GPL условия, делающие невозможным превращение открытого кода в собственнический.

Вкратце условия использования и распространения Berkeley DB таковы:

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

Должно быть свободно распространяемым в исходных текстах, или.

Пользователь должен получить у нас лицензию.

Клиентам, не желающим распространять свои продукты в виде открытого кода, мы предлагаем по разумным ценам лицензии на использование, распространение и расширение Berkeley DB.

Мы стараемся прислушиваться к нуждам сообщества открытого кода. В частности, мы разработали специальные лицензионные соглашения с проектом Gnome, поощряющие использование и распространение в его составе Berkeley DB.

Berkeley DB соответствует определению открытого кода [6]. Лицензия была тщательно составлена таким образом, чтобы Berkeley DB с одной стороны оставалась продуктом с открытым кодом, а с другой обеспечивала прибыль на инвестицию, достаточную для финансирования дальнейшей разработки и поддержки продукта. Ныне действующее лицензионное соглашение уже в течение трех лет дает нам возможность поддерживать разработку Berkeley DB. Если бы не эта лицензия, такого программного продукта могло и не быть.

Резюме.

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

– программный продукт с открытым кодом. В дистрибутив входит все необходимое для сборки и развертывания или переноса его на новые операционные системы.

Sleepycat Software распространяет Berkeley DB на условиях лицензионного соглашения, базирующегося на Berkeley UC и GPL. Лицензия гарантирует, что Berkeley DB останется продуктом открытого кода и обеспечивает Sleepycat возможность зарабатывать средства на финансирование дальнейшего развития своего программного обеспечения.

©Drkb::03005.

Bin -> Dec.

Code: Function BinToInt(const Value: string): Integer; {©Drkb v.3(2007): www.drkb.ru}. Var. I, strLen: Integer; Begin. Result := 0; StrLen := Length(Value); For i := 1 to strLen do. If Value[i] = '1' then. Result := Result or (1 shl (strLen - i)). Else. Result := Result and not (1 shl (strLen - i)); End;

BIN --> Byte.

Code: Function BinStrToByte(a_sBinStr: string): byte; Var. I: integer; Begin. Result := 0; For i := 1 to length(a_sBinStr) do. Result := (Result shl 1) or byte(a_sBinStr[i] = '1'); End;

©Drkb::00944.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

BIN --> Integer.

Code: Function BinToInt(Value: string): Integer; Var. I, iValueSize: Integer; Begin. Result := 0; IValueSize := Length(Value); For i := iValueSize downto 1 do. If Value[i] = '1' then Result := Result + (1 shl (iValueSize - i)); End;

©Drkb::00939.

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

Bitmap в StringGrid ячейке

В обработчике события OnDrawCell элемента StringGrid поместите следующий код:

Blitting, Спрайты и Анимация

Автор: Азиз (JINX).

Специально для Королевства Delphi.

BLOB has been modified., Index is out of date.

Объяснение от Борланд:

Index out Date ($2F02) is an error that occurs while using Paradox tables when the data in a table and a corresponding index is not consistent. In most cases (see below for the one exception), short of malicious behavior such as renaming an index, adding some data to the table, then renaming the index back, there is no programmatic way to cause this error to occur. There is no way to determine which index is out of date. All indexes must be recreated.

Blob has been modified ($3302) is an error that occurs when the Blob portion of the record contained in the .DB file has become inconsistent with the Blob portion in the .MB file. This could occur when the write to the .DB file was successful but the .MB file did not get updated, or visa-versa.

There are a few mechanisms to fix a table where these errors have occurred.

1. First try re-starting the application. It is possible that the BDE has become unstable and is reporting incorrect errors. Also try opening the table with a different application.

2. Use Paradox 7 or 8 to run the Table Repair utility. Please see original documentation for more information.

3. Run TUtility and rebuild the table. TUtility is an unsupported utility available for download from the Borland web site in the {Utilities, programs and updates section}.

4. Delete all indexes and recreate them (Index out Date ($2F02) error only). To do this you'll need to know the structure of all your indexes (including primary) before recreating them, which means you need to know the structure of all indexes before the error occurs.

There are 8 known possible causes for this error.

1. Incorrectly setting the LOCAL SHARE property.

Most commonly this occurs via Peer-to-Peer networking. In this case the two different database engines are on two CPUs, even though they may be the same version. See { BDE setup for Peer-To-Peer(Non-Dedicated) Networks} for additional information on Peer-to-Peer setup.

Another condition is when two different database engines execute on the same CPU concurrently and access data locally. This would be true when any combination of following are used concurrently: The Paradox Engine, BDE 16 bit, BDE 32 bit, Paradox for DOS. In this case each engine must set LOCAL SHARE to TRUE. Note that if use two applications which both use the same database engine (for example: Delphi 3 and C++ Builder 3) concurrently are run LOCAL SHARE does not need to be set to TRUE. In this case, all locking and cached data is in a central memory pool which all BDE applications have access to. Also, if two different database engines use data remotely, LOCAL SHARE must be set to TRUE.

Code should be used at startup to check the setting of local share. Look at the {DbiOpenCfgInfoList } BDE API function call for more information.

2. Error transmitting data from the workstation to the server.

Most commonly, this occurs with bad network hardware (cable, card, hub, etc.). This has been determined to be a problem even though there were no other errors are detected in data transmission. To determine if this is the cause for your error, try eliminating one CPU at a time from using the data and see if the problem continues.

3. Bad VREDIR.VXD on any client accessing tables Windows 95 ONLY:

Several versions (notably 4.00.1113 and 4.00.1114) of the file VREDIR.VXD may need to be updated.

Reports have shown that using the original release of VREDIR.VXD (4.00.950) and a new release (4.00.1116) do not result in the errors "Blob has been modified" and/or "Index is out of date." If any one of the clients has a "bad" version of this device driver, the error can occur on any machine, not just the machine with the bad driver.

This error most likely occurs in 16Bit versions of the Borland Database Engine, although it still can occur in 32Bit versions.

For further information on the update of VREDIR.VXD, Please check the following Microsoft Articles: {Q174371} and {Q165403}.

4. For Windows 95 clients only, when using data on Windows NT: Add the following key in your registry: HKEY_LOCAL_MACHINESystemCurrentControlSetServicesVxDVredir.

Then create the string or Binary Value (either one works) with a name of DiscardCacheonOpen and make it equal to 1.

Note that this an undocumented registry entry obtained from Microsoft. Questions on its functionality should be directed to Microsoft.

5. Problem with opportunistic locking Windows NT ONLY: Try turning off opportunistic locking in the Windows NT registry: See Microsoft Article {Q129202}.

Note: Borland internal testing has not indicated this setting to be significant. However, some Borland customers have indicated this to solve the problem.

6. Improperly closing files such as due to loss of power or restarting a workstation or the server without closing files first may cause this problem. Paradox tables are not designed to withstand such behavior. If this is a possibility in your environment, we recommend you use a Client Server database that can recover from such conditions.

7. Extremely large numbers of indexes, especially involving Referential Integrity can cause this problem and especially when using Windows NT as the server. Borland recommends using a Client Server database under this condition. However, if you are using Windows NT as your server, switching to Novell Netware or Windows 95 as the server may resolve the problem as well.

8. The one programmatic way you can make this error occur is if you attempt to post a duplicate value to a unique, non-primary index at the same time you attempt to open the same table. This problem only occurs if local share is set to False and only occurs on local drives.

Unverified solutions.

1. Windows 95 Only: Bring up the network properties screen on all Workstations and enter the netBEUI properties screen. On the advanced tab, make sure that "Set this protocol to be the default protocol" is checked.

2. Windows 95 Only: If the previous suggestion did not work, try removing the following protocols in order. Remove one at a time and then re-test your problem:

1. NETBIOS support for IPX/SPX-compatible Protocol.

2. TCP/IP.

3. IPX/SPX-compatible Protocol If the problem disappears, attempt to add back in all protocols except for the last one that was taken out. Again, make sure netBEUI's default protocol check box is checked.

3. Windows NT Only used as a Workstation: On the Network Bindings page of the Network Properties, set the NetBEUI Protocol to be at the top of all services. The TCP/IP stack is known for having a lot of overhead that might cause timing problems. Since NT will send requests back in the same protocol as it is sent, changing the bindings on a NT machine used as a server will have no effect.

Other resources.

1. {The Delphi Magazine} has a number of interesting articles on this subject as well. See { www.itecuk.com/Delmag/Paradox.htm} for details.

©Drkb::02579.

Примечание от Vit:

Обычно такие ошибки возникают из-за проблем с кэшированием измений в базе данных, особенно при использовании BLOB/Memo полей и особенно при многопользовательском доступе. В простейшем случае снизить частоту возникновения этой ошибки на несколько порядков помогает вызов метода FlushBuffers после каждого изменения таблицы:

Table1.post;

Table1.FlushBuffers;

©Drkb::02576.

BMP --> EMF (Enhanced Metafile).

Code: Function bmp2emf(const SourceFileName: TFileName): Boolean; // Converts a Bitmap to a Enhanced Metafile (*.emf). Var. Metafile: TMetafile; MetaCanvas: TMetafileCanvas; Bitmap: TBitmap; Begin. Metafile := TMetaFile.Create; Try. Bitmap := TBitmap.Create; Try. Bitmap.LoadFromFile(SourceFileName); Metafile.Height := Bitmap.Height; Metafile.Width := Bitmap.Width; MetaCanvas := TMetafileCanvas.Create(Metafile, 0); Try. MetaCanvas.Draw(0, 0, Bitmap); Finally. MetaCanvas.Free; End; Finally. Bitmap.Free; End; Metafile.SaveToFile(ChangeFileExt(SourceFileName, '.emf')); Finally. Metafile.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Bmp2emf('C:\TestBitmap.bmp'); End;

Borland Delphi/C++Builder ToolsAPI, или взгляд на Borland IDE изнутри

Андрей Семак

Введение.

Рано или поздно каждому профессиональному разработчику программного обеспечения становится тесной среда обитания. По мнению автора, читатель понял, что речь идет о среде разработки, в которой обитает разработчик. У кого это "дом", у кого "строительная площадка", а у кого и то, и другое. В этой статье мы рассмотрим возможность расширения нашего дома. Мы покажем, как именно можно наращивать мощность IDE своими силами, будь то среда разработки Borland Delphi или Borland C++ Builder.

У многих из вас возникало желание добавить несколько полезных функций в любимое IDE. Разработчики фирмы Borland не оставили без внимания эту полезную возможность. Они разработали набор интерфейсов, позволяющих расширять возможности среды, хотя, к сожалению, отсутствие документации по данному вопросу мешает самостоятельному изучению. Жалкие комментарии в исходных текстах не могут воспроизвести всю мощь, которую предоставляет IDE разработчику расширений. Автор статьи попытается передать читателю опыт своих изысканий и постарается своими советами уберечь читателя от многих подводных камней.

Документ построен таким образом, чтобы мы переходили от этапа к этапу от простого к сложному. Насколько это удалось, судить вам. Вместе c вами мы рассмотрим на примерах все сервисы, предоставляемые IDE Borland Delphi\C++Builder.

Итак, начнем?

Что такое ToolsAPI?

Многие спросят: "Что такое ToolsAPI?" На что смело можно ответить: ToolsAPI - это набор программных интерфейсов, позволяющих: получать информацию о происходящих в IDE событиях, вызывать функции IDE, создавать свои собственные функции, которые потом будут доступны в среде разработки. Этот набор позволяет нам создавать свои собственные меню, кнопки управления и так далее.

Этот набор интерфейсов размещен в файле ToolsAPI.pas, находящийся в директории {IDEROOT}\Source\Toolsapi\ вашего каталога Delphi\C++Builder.

Старый "стиль" и "новый стиль" ToolsAPI.

Существует две модели интерфейсов ToolsAPI, или как их называют - "старый" и "новый" стили. Старый стиль был реализован в средах Delphi 3-4 и C++ Builder 3.-4. Начиная с Delphi 5 и C++ Builder 5, в среду встроена реализация нового стиля. В этом документе мы будем рассматривать только "новый стиль". "Почему?" - возможно, спросите вы. А потому, - ответит автор - что фирма Borland более не развивает интерфейсы "старого" стиля. Это не значит, что расширения, написанные в старом стиле, не будут работать. Разработчики Borland оставили API старого стиля для совместимости с предыдущими версиями IDE. Интерфейсы "старого" ToolsAPI находятся в директории Source\Toolsapi\ в следующих файлах:

1. editintf.pas

2. exptintf.pas

3. fileintf.pas

4. istreams.pas

5. toolintf.pas

6. vcsintf.pas

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

Примечание: Если читатель будет интересоваться "старым" стилем, автор рекомендует обратиться в Интернете к странице Сергея Орлика (в данный момент Сергей работает в российском представительстве Borland). К сожалению, с октября 1999 года страница автором более не поддерживается. Также на его сайте есть ссылка на PDF документ, демонстрирующий архитектуру ToolsAPI "нового" стиля, но для Delphi/C++Builder 4 (http://www.geocities.com/SiliconValley/Way/9006/otapi.pdf).

Особенности ToolsAPI в Delphi/C++ Builder различных версий.

На первый взгляд IDE Delphi и C++Builder идентичны. Автор возьмет на себя смелость заявить, что и внутренних отличий так же практически нет. Во всяком случае, в разрезе ToolAPI. То есть, ToolsAPI Delphi5 тождественен Тоо1sАРI С++Builder5 и так далее.

Расширения, собранные на Delphi без проблем работают в C++Builder аналогичной версии. Согласитесь, это очень удобно. Создав полезную функцию для IDE Delphi, вы всегда сможете использовать её в С++Builder той же версии.

Многие спрашивают: "А как же столь популярный Borland Jbuilder?" Jbuilder - это продукт полностью написанный на Java. Он также имеет ToolsAPI, но кардинально отличается от рассматриваемого нами.

Примечание: В этом документе Borland Jbuilder рассматриваться не будет.

Типы экспертов.

Немного терминологии. "Экспертом" мы называем набор функций, расширяющий возможности IDE и выполненный в виде загружаемого модуля. В "новом" стиле нет понятия "Expert" (пережиток "старого стиля"), но есть понятие "Wizard". На самом деле это одно и тоже. Автор взял за основу слово "Эксперт" потому что, по его мнению, оно более точно характеризует предмет нашего с вами внимания.

Существуют два типа исполнения экспертов:

1. В виде пакетов (расширение файла .BPL)

2. В виде библиотек (расширение файла .DLL)

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

Пакеты.

Эксперты, выполненные в виде пакетов (BPL), регистрируются как обычные пакеты с компонентами прямо из среды разработки.

Для этого достаточно зайти в меню "Component" -> "Install Packages" -> "Add" и выбрать BPL с экспертом.

рис. 1.

Чтобы временно отключить эксперта, достаточно снять галочку напротив пакета в списке этого окна. Для того, чтобы удалить его из системы, следует выбрать пакет в списке и нажать кнопку "Remove".

Библиотеки.

У этого типа экспертов более сложная регистрация. Для регистрации нам необходимо запустить редактор реестра вашей операционной системы (regedit.exe) и открыть ключ HKEY_CURRENT_USER\Software\Borland\Delphi(или C++Builder)\X.X\Experts, где X.X версия Delphi\C++Builder.

Пример показан на рис. 2.

рис. 2.

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

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

Особенности отладки экспертов.

Отладка экспертов осуществляется так же, как и отладка DLL и BPL. Для отладки необходимо в параметрах запуска указать приложение среды как Host Application (см рис. 3).

рис. 3.

В параметрах проекта эксперта необходимо выключить оптимизацию и включить Stack Frames, как показано на рис. 4. После установки описанных опций, необходимо сделать Build всему проекту эксперта.

рис. 4.

Под операционной системой Windows XP эксперты, разрабатываемые под Delphi5 и Delphi6, отлаживать проблематично, поскольку по не известным автору причинам отладчик отказывается загружать Debug Symbol Table. Это ведет к невозможности использования точек останова для отладчика (Break points), что приводит к невозможности осуществлять отладку.

Решение этой проблемы вы найдете в Интернете на сайте компании Devrace по адресу http://www.devrace.com/files/debug_xp.zip. Это небольшой эксперт, разработанный автором статьи, после установки которого принудительно загружается Symbol Table во время подключения проекта в текущий процесс отладчика. Данный эксперт лишний раз демонстрирует полезность и практичность расширений IDE.

Что такое интерфейсы и особенности их использования в ToolsAPI.

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

Также рекомендуется обратить внимание читателя на то, как развиваются интерфейсы ToolsAPI от версии к версии. Если читатель решит создавать расширения, которые будут использоваться в нескольких версиях IDE, то можно рекомендовать использовать ToolsAPI от самой низкой версии используемого IDE. Это связано с тем, что развитие интерфейсов порождает правило о совместимости сверху вниз. От высшей версии к низшей. И ни в коем случае наоборот.

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

Основные сервисы ToolsAPI.

Итак, время заглянуть в файл ToolsAPI.pas. Этот файл содержит целый ряд сервисов, которые помогут получать информацию из IDE.

Знакомьтесь - IBorlandIDEServices. Это самый "главный" интерфейс. Из него мы получим все необходимые нам интерфейсы-сервисы. Все интерфейсы, содержащие в себе слово "Services" являются производными от IBorlandIDEServices.

Указатель на IBorlandIDEServices можно получить двумя способами.

1. Через экспортную функцию регистрации эксперта путем присвоения указателя глобальной переменной BorlandIDEServices. (в случае с библиотекой)

2. Через уже определенную глобальную переменную BorlandIDEServices (используя пакеты)

Методы получения указателя на IBorlandIDEServices мы рассмотрим на примере в разделе 9. Например, нам необходимо получить указатель на INTAServices. Для этого достаточно написать следующую функцию:

Code: Function NTAServices: INTAServices; Begin. Result := (BorlandIDEServices as INTAServices); End;

Byte --> BIN.

Code: Function ByteToBinStr(a_bByte: byte): string; Var. I: integer; Begin. SetLength(Result, 8); For i := 8 downto 1 do. Begin. Result[i] := chr($30 + (a_bByte and 1)); A_bByte := a_bByte shr 1; End; End;

Как получить TextRange страницы без фреймов?

Code: HTML_Doc := WebBrowser1.Document As IHTMLDocument2; Window := HTML_Doc.parentWindow As IHTMLWindow2; Body := HTML_Doc.get_body As IHTMLBodyElement; Range := oBody.createTextRange;

Как добраться до конкретного фрейма?

Code: Var. HTML_Doc: IHTMLDocument2; Window: IHTMLWindow2; ORange1: variant; Name_frame: OleVariant; HTML_Doc := WebBrowser1.Document as IHTMLDocument2; Window := HTML_Doc.parentWindow as IHTMLWindow2; Name_frame := 'mainFrame'; ORange1 := Window.frames.item(name_frame).document.body.createTextRange;

Есть ли соединение с инетом?

За это отвечает ф-ии InternetGetConnectedState() из wininet.dll или InetIsOffLine() из url.dll.

©Drkb::03570.

Автор: Song.

Взято с Vingrad.ru http://forum.vingrad.ru.

Единственный 100% достоверный способ узнать находится ли комп в интернете это скачать что-то со стабильного внешнего сервера - такого как Microsoft, Yahoo, AT&T... По другому ни одна функция локального компьютера не сможет отличить нахождение компьютера в интранете и в интернете... Я в своей программе для определения коннекта с интернетом пингую наш собственный DNS сервер, который стоит за Firewall и естественно пинговка идет через провайдера интернет. (В некоторых Firewall может быть запрещен Ping - тогда надо именно попытаться скачать что-нибудь).

©Drkb::03571.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

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

Совместимость: Delphi 3.x (или выше).

Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:

Function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';

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

If InetIsOffline(0) then.

ShowMessage('This computer is not connected to Internet!').

Else.

ShowMessage(You are connected to Internet!');

Эта функция возвращает TRUE если соединение с интернетов отсутствует, или FALSE если соединение установлено.

Замечание:

Параметр Flag игнорируется, соответственно используем ноль.

Эта DLL обычно проинсталлирована на большинстве компьютеров. Она также существует в Win98 либо поставляется с Internet Explorer 4 или выше, Office 97 и т.д..

Более подробно можно прочитать в MSDN. Оригинал: http://msdn.microsoft.com/library/psdk/shellcc/shell/Functions/InetIsOffline.htm.

Автор ответа: Vitaly Zayko.

©Drkb::03572.

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

Code: Interface. Uses. Windows, SysUtils, Registry, WinSock, WinInet; Type. TConnectionType = (ctNone, ctProxy, ctDialup); Function ConnectedToInternet: TConnectionType; Function RasConnectionCount: Integer; Implementation. //For RasConnectionCount ======================= Const. CERROR_BUFFER_TOO_SMALL = 603; CRAS_MaxEntryName = 256; CRAS_MaxDeviceName = 128; CRAS_MaxDeviceType = 16; Type. ERasError = class(Exception); HRASConn = DWORD; PRASConn = ^TRASConn; TRASConn = record. DwSize: DWORD; RasConn: HRASConn; SzEntryName: array[0..cRAS_MaxEntryName] of Char; SzDeviceType: array[0..cRAS_MaxDeviceType] of Char; SzDeviceName: array [0..cRAS_MaxDeviceName] of Char; End; TRasEnumConnections = Function(RASConn: PrasConn; { buffer to receive Connections data }. Var BufSize: DWORD; { size in bytes of buffer }. Var Connections: DWORD { number of Connections written to buffer }. ): Longint; Stdcall; //End RasConnectionCount ======================= Function ConnectedToInternet: TConnectionType; Var. Reg: TRegistry; BUseProxy: Boolean; UseProxy: LongWord; Begin. Result := ctNone; Reg := TRegistry.Create; With REG do. Try. Try. RootKey := HKEY_CURRENT_USER; If OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings', False) then. Begin. //I just try to read it, and trap an exception. If GetDataType('ProxyEnable') = rdBinary then. ReadBinaryData('ProxyEnable', UseProxy, SizeOf(Longword)). Else. Begin. BUseProxy := ReadBool('ProxyEnable'); If bUseProxy then. UseProxy := 1. Else. UseProxy := 0; End; If (UseProxy <> 0) and (ReadString('ProxyServer') <> '') then. Result := ctProxy; End; Except. //Obviously not connected through a proxy. End; Finally. Free; End; //We can check RasConnectionCount even if dialup networking is not installed. //simply because it will return 0 if the DLL is not found. If Result = ctNone then. Begin. If RasConnectionCount > 0 then Result := ctDialup; End; End; Function RasConnectionCount: Integer; Var. RasDLL: HInst; Conns: array[1..4] of TRasConn; RasEnums: TRasEnumConnections; BufSize: DWORD; NumConns: DWORD; RasResult: Longint; Begin. Result := 0; //Load the RAS DLL. RasDLL := LoadLibrary('rasapi32.dll'); If RasDLL = 0 then Exit; Try. RasEnums := GetProcAddress(RasDLL, 'RasEnumConnectionsA'); If @RasEnums = nil then. Raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll'); Conns[1].dwSize := SizeOf(Conns[1]); BufSize := SizeOf(Conns); RasResult := RasEnums(@Conns, BufSize, NumConns); If (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns; Finally. FreeLibrary(RasDLL); End; End;

Как определить MAC адрес NIC?

Вот на что наткнулся в одном из ФАКов:

Вариант1:

From : Sergey Gazimagomedov 2:453/11.13.

Мне нужен был МАС адрес, так я его получал, пользуясь NetBIOS.

Добавляешь имя NetBIOS и посылаешь на имя станции, нужной для определения(можно.

И своей) датаграмный пакет с заполненным NCB.

Вот исходник моей функции для определения МАС адреса.

Code: UCHAR MYLIBAPI GetAdapterID(char *Name, // NetBIOS ??? ??????? UINT lana_num, CARDID *ID) // 6 ???????? ?????? { UCHAR rc = 0; UCHAR Status[256]; While( lstrlen(Name) - 15). Lstrcat(Name, " "); Memset(&SNcb, 0, sizeof(NCB)); SNcb.ncb_command = NCBASTAT; SNcb.ncb_buffer = (LPSTR)Status; SNcb.ncb_length = 256; Lstrcpy(SNcb.ncb_callname, Name); SNcb.ncb_lana_num = lana_num; Rc = Netbios( &SNcb ); If(rc ==0){ Memcpy(ID, Status, 6); } Return(SNcb.ncb_cmd_cplt); }

Как добавить пункт в контекстное меню IE?

В реестре по адресу:

HKEY_CURRENT_USER.

SOFTWARE.

Microsoft.

Internet Explorer.

MenuExt.

Два параметра, посмотришь на другие-поймешь что они означают.

Автор ответа: Mikel.

©Drkb::03498.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как передать картинку по сети через ServerSocket?

Да без проблем. Звиняйте, что на сях, но, тем не менее, на Борланд сях.

Со стороны, откуда посылаем (у нас это клиент), пишем:

Code: TFileStream* str = new TFileStream("M:\\MyFile.jpg",fmOpenRead); //ИЛИ, если мы работаем без сохранения (тогда не создается файл). TMemoryStream* str = new TMemoryStream (); Str->Position = 0; Image1->Picture->Bitmap->SaveToStream(str); //и, наконец, шлем на сервер битмап. Str->Position = 0; ClientSocket1->Socket->SendStream(str);

Как запросить страницу с сайта?

Это можно сделать с помощью TClientSocket.

Code: Unit Unit1; Interface. Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ScktComp; Const Request: AnsiString = 'GET / HTTP/1.1' + #$D#$A + 'Accept: application/vnd.ms-excel, application/msword, */*' + #$D#$A + 'Accept-Language: en-us' + #$D#$A + 'Accept-Encoding: gzip, deflate' + #$D#$A + 'User-Agent: Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)' + #$D#$A + 'Host: vingrad.com' + #$D#$A + 'Connection: Keep-Alive' + #$D#$A + #$D#$A; Type. TForm1 = class(TForm). Skt: TClientSocket; Button1: TButton; Memo1: TMemo; Procedure Button1Click(Sender: TObject); Procedure SktRead(Sender: TObject; Socket: TCustomWinSocket); Procedure SktConnect(Sender: TObject; Socket: TCustomWinSocket); Private. { Private declarations }. Public. { Public declarations }. End; Var Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. Skt.Host := 'vingrad.ru'; Skt.Port := 80; Skt.Open; End; Procedure TForm1.SktRead(Sender: TObject; Socket: TCustomWinSocket); Begin. Memo1.Lines.Text := Memo1.Lines.Text + Socket.ReceiveText; End; Procedure TForm1.SktConnect(Sender: TObject; Socket: TCustomWinSocket); Begin. Socket.SendText(Request); End; End.

Как можно получить звук с микрофона?

Code: Unit receiver; Interface. Uses mmsystem, classes; Const. Samp_per_sec = 44100; Samp_cnt = samp_per_sec div 5; Buf_len = samp_cnt * 2; Type. PSample16M = ^TSample16M; TSample16M = SmallInt; PArrayOfSample = ^TArrayOfSample; TArrayOfSample = array[1..samp_cnt] of TSample16M; TReceiver = class. Private. Hwi: Integer; Fmt: tWAVEFORMATEX; Whdr1: WAVEHDR; Buf1: TArrayOfSample; Whdr2: WAVEHDR; Buf2: TArrayOfSample; FStoped: Boolean; FOnChange: TNotifyEvent; Procedure SetStoped(const Value: Boolean); Public. Peak: Integer; Buffer: PArrayOfSample; Destructor Destroy; override; Procedure Start; Procedure Stop; Property Stoped: Boolean read FStoped write SetStoped; Property OnChange: TNotifyEvent read FOnChange write FOnChange; End; Var rec: TReceiver; Implementation. Procedure waveInProc(const hwi, uMsg, dwInstance: Integer; var hdr: WAVEHDR; const dwP2: Integer); stdcall; Const divs = samp_cnt div 100; Var. I, p: Integer; Buf: PArrayOfSample; Begin. If rec.Stoped then Exit; Case uMsg of. WIM_OPEN: begin end; WIM_DATA: begin. Rec.Buffer := PArrayOfSample(hdr.lpData); Buf := PArrayOfSample(hdr.lpData); P := 0; For i := 0 to samp_cnt div divs do p := p + Abs(buf[i * divs]); Rec.Peak := p div (samp_cnt div divs); If Assigned(rec.FOnChange) then rec.FOnChange(rec); WaveInUnprepareHeader(hwi, @hdr, SizeOf(WAVEHDR)); WaveInPrepareHeader(hwi, @hdr, SizeOf(WAVEHDR)); WaveInAddBuffer(hwi, @hdr, SizeOf(WAVEHDR)); End; WIM_CLOSE: begin end; End; End; { TReceiver }. Destructor TReceiver.Destroy; Begin. Stoped := True; Inherited; End; Procedure TReceiver.SetStoped(const Value: Boolean); Begin. FStoped := Value; If Value then. Begin. WaveInStop(hwi); WaveInUnprepareHeader(hwi, @whdr1, SizeOf(WAVEHDR)); WaveInUnprepareHeader(hwi, @whdr2, SizeOf(WAVEHDR)); WaveInReset(hwi); WaveInClose(hwi); End. Else. Begin. With fmt do. Begin. WFormatTag := WAVE_FORMAT_PCM; NChannels := 1; NSamplesPerSec := samp_per_sec; NBlockAlign := 2; NAvgBytesPerSec := nSamplesPerSec * nBlockAlign; WBitsPerSample := 16; CbSize := 0; End; WaveInOpen(@hwi, WAVE_MAPPER, @fmt, Cardinal(@waveInProc), hInstance, CALLBACK_FUNCTION); With whdr1 do. Begin. LpData := @buf1; DwBufferLength := buf_len; DwBytesRecorded := 0; DwUser := 0; DwFlags := 0; DwLoops := 0; LpNext := nil; Reserved := 0; End; WaveInPrepareHeader(hwi, @whdr1, SizeOf(WAVEHDR)); WaveInAddBuffer(hwi, @whdr1, SizeOf(WAVEHDR)); With whdr2 do. Begin. LpData := @buf2; DwBufferLength := buf_len; DwBytesRecorded := 0; DwUser := 0; DwFlags := 0; DwLoops := 0; LpNext := nil; Reserved := 0; End; WaveInPrepareHeader(hwi, @whdr2, SizeOf(WAVEHDR)); WaveInAddBuffer(hwi, @whdr2, SizeOf(WAVEHDR)); WaveInStart(hwi); End; End; Procedure TReceiver.Start; Begin. Stoped := False; End; Procedure TReceiver.Stop; Begin. Stoped := True; End; Initialization. Rec := TReceiver.Create; Finalization. Rec.Free; End.

Как можно получить звук с помощью MediaPlayer?

Пример взят из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи...".

Code: Procedure TForm1.btRecordClick(Sender: TObject); Begin. With Media do. Begin. { Set FileName to the test.wav file to }. { get the recording parameters. }. FileName := 'd:\test.wav'; { Open the device. }. Open; { Start recording. }. Wait := False; StartRecording; End; End; Procedure TForm1.btStopClick(Sender: TObject); Begin. With Media do. Begin. { Stop recording. }. Stop; { Change the filename to the new file we want to write. }. FileName := 'd:\new.wav'; { Save and close. The file. }. Save; Close; End; End;

Программирование Sound Blaster.

Статья взята с " target=_blankhttp://www.programmist.info[/i].

Sound Blaster воспроизводит как синтезированный звук так и оцифровые звуки.

В этом файле будет расмотрено программирование воспроизведения цифровых.

Выборок через Sound Blaster DSP.

+-------------------------------------+-------------------------------------

| Порты ввода/вывода SoundBlaster DSP |

+=====================================+

Чип DSP ( Цифровой Звуковой Процессор ) программируется через пять портов,

Которые определяются через базовый адрес Sound Blaster:

2x6h - DSP Сброс.

2xAh - DSP Чтение.

2xCh - DSP Запись (команды/данные) ,

Состояние буфера записи DSP( Бит 7 ).

2xEh - Состояние буфер чтения DSP ( Бит 7 ),

Подтверждение прерывания DSP.

Пятый порт только для Sound Blaster 16.

2xFh - подтверждение прерывания DSP с 16 битами.

Где x = 1 для базового адреса 210h.

X = 2 для базового адреса 220h.

.

.

X = 6 для базового адреса 260h.

+-----------+----------------------------------------------------------------

| Сброс DSP |

+===========+

Необходимо сбросить DSP прежде, чем начать работу с ним. Сброс осуществляется.

По следующему алгоритму:

1) Запишите 1 в порт сброса (2x6).

2) Ждите 3 микросекунды.

3) Запишите 0 в порт сброса (2x6).

4) Читайте порт состояния буфера чтения (2xE) пока бит 7 = 1.

5) Опрашивайте порт данных чтения (2xA) пока вы не получите AAh.

Для сброса DSP требуется около 100 мкс. Если после этого вы не получили.

AAh. Значит, либо нет звуковой платы, или задан был неверный базовый.

Адрес.

Пример:

#define MAX_BASE_SB 5.

Int bases[MAX_BASE_SB]={ 0x220, 0x230, 0x240, 0x250, 0x260 };

Int baseAddrSB=0x220;

// Прочитать.

Unsigned char pascal ReadSB.

(void).

{

Unsigned int value;

While (!(inp((baseAddrSB+0xE)) & 0x80));

Value = inp((baseAddrSB+0xA));

Return value;

}

// Проверить наличие.

Char pascal CheckSB.

( void ).

{

Int i, j;

For ( j=0; j 23 KHz. Затем младший.

Байт длины, потом старший.

WriteSB(DMA_8_BIT_DAC);

WriteSB(lo(len));

WriteSB(hi(len));

24h - Включение записи с ADC 8 Бит 4KHz - > 23 KHz.

74h - Включение вывода на DAC 4 Бит ADPCM 4KHz - > 12 KHz.

75h - Включение вывода на DAC 4 Бит ADPCM с 4KHz - > 12 KHz с байтом ссылки.

76h - Включение вывода на DAC 2.6 Бит ADPCM 4KHz - > 13 KHz.

77h - Включение вывода на DAC 2.6 Бит ADPCM с 4KHz - > 13 KHz с байтом ссылки.

16h - Включение вывода на DAC 2 Бит ADPCM 4KHz - > 11 KHz.

17h - Включение вывода на DAC 2 Бит ADPCM с 4KHz - > 11 KHz с байтом ссылки.

ADPCM ( Адаптивная Импульсно-кодовая Модуляция) - это звуковая методика.

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

Чем их фактические значения. В режимах с байтами ссылки, первый байт -

Фактическое начальное значение. Наличие режимов с и без байтов ссылки значит.

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

Bxh - программмирование режима DMA с 16 битным цифровым звуком.

( Только для SB16 ).

Командная последовательность:

Команда, Режим, Lo(Length-1), Hi(Length-1):

Первый байт команды состоит:

D7 D6 D5 D4 D3 D2 D1 D0.

--+--+--+--+---+----+-----+--

1 0 1 1 A/D A/I FIFO 0.

---------------+----+-----+--

0=D/A 0=SC 0=off.

1=A/D 1=AI 1=on.

Общие команды:

B8 - одиночный цикл с 16-битной записи звука.

B0 - одиночного цикла с 16-битным воспроизведением.

BE - автоинициализируемая 16-битная запись.

B6 - автоинициализируемое 16-битной воспроизведение.

Режим:

D7 D6 D5 D4 D3 D2 D1 D0.

---+--+-------+-----+--+--+--+--

0 0 Стерео Знак 0 0 0 0.

0-Моно 0-без.

1-Стерео 1-со знаком.

Cxh - программирование режим DMA с 8-битным цифровым звуком.

( Только для SB16 ).

Те же самые команды, что для 16-бит.

C8 - одиночный цикл с 8-битной записи звука.

C0 - одиночного цикла с 8-битным воспроизведением.

CE - автоинициализируемая 8-битная запись.

C6 - автоинициализируемое 8-битной воспроизведение.

FIFO используется чтобы удалять несогласованности в тот период выборки,

Когда звуковая плата не способна получить DMA, когда это требуется.

Без FIFO плата делает попытку захвата DMA в точно тот момент, когда.

Требуется выборка. Если другое устройство с более высоким приоритетом.

Обращается к DMA, звуковая плата ожидает и скорость выборки может.

Уменьшаться. FIFO позволяет во время выборки с DMA быть более гибким DSP.

Без потери звукового качества. FIFO очищается всякий раз, когда команда.

Посылается DSP. В режиме одиночного цикла, DSP постоянно перепрограммируется.

С FIFO DSP может еще содержать данные, который не были выданы, когда.

Команда очистила DAC. Чтобы избежать этого, FIFO должен быть переключен.

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

Режим, когда DSP не перепрограммируется.

1Ch - Включение вывода на DAC 8 Бит 4KHz - > 23 KHz с автоинциализацией.

90h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz с автоинициализацией.

48h - Установить длину блока на пересылку перед посылкой 91h, 99h.

Сначала младший байт затем старший длину.

91h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz стерео.

99h - Включение записи с ADC 8 бит 4kHz - > 44 KHz стерео.

WriteSB(SET_LEN_DMA_8_BIT);

WriteSB(lo(len));

WriteSB(hi(len));

WriteSB(DMA_8_BIT_DAC_HI);

D0h - остановить 8-битный DMA.

D4h - возобновить 8-битный DMA.

D5h - остановить 16-битный DMA.

D6h - возобновить 16-битный DMA.

Эти команды пригодны как и для автоинциализированного режима,

Так и для одиночных циклов.

D9h - Выход из авто инициализируемого режима DMA с 16 битами.

После окончания текущего блока.

DAh - Выход из авто инициализируемого режима DMA с 8 битами.

После окончания текущего блока.

E1h - Получить номер версии DSP. После посылки этой команды, прочитайте.

Из DSP два байта. Первый байт - главный номер версии и второй.

Байт - малый номер версии. Версия 4.00 - это SB16.

Версия | Стерео | Частота | FIFO | 16 бит.

--------+--------+----------+------+--------

< 2.00 | - | до 21379 | - | -

>= 2.00 | - | до 21379 | + | -

>= 2.01 | - | до 43478 | + | -

>= 3.00 | + | до 43478 | + | -

>= 3.01 | + | до 43478 | + | +

Пример определения версии:

Int pascal VersionSB.

( void ).

{

Char ch, ch1;

WriteSB(0xE1);

Ch=ReadSB();

Ch1=ReadSB();

VerSB=ch<<8 | ch1;

If ( verSB>=0x200 ).

Fifo=1;

If ( verSB>=0x201 ).

MaxFrequency=1;

If ( verSB>=0x300 ).

Stereo=1;

If ( verSB>=0x301 ).

SixteenBit=1;

Return verSB;

}

+----------------------+----------------------------------------------------

| Программирование DMA |

+======================+

Контроллер DMA (Прямого Доступа В память) управляет пересылками данных.

Между устройствами ввода/вывода и памятью без использования центрального.

Процессора. IBM совместимая ЭВМ имеет два контроллера DMA один для.

Пересылок с 8 битами и другой для пересылок с 16 битами. Контроллер DMA,

Вместе с внешним регистром страницы, способен на перемещение блоков по 64 КБ.

Ниже приведена информация по программированию DMA.

Адреса портов для адреса DMA и регистров счета.

Контроллер | Адрес | Функция.

---------------+---------+-----------------

DMA 1 | 00 | Канал 0 адреса.

C 8 битами | 01 | Канал 0 счета.

Подчиненный | 02 | Канал 1 адрес.

| 03 | Канал 1 счета.

| 04 | Канал 2 адреса.

| 05 | Канал 2 счета.

| 06 | Канал 3 адреса.

| 07 | Канал 3 счета.

--------------+---------+------------------

DMA 2 | C0 | Канал 4 адреса.

С 16 битами | C2 | Канал 4 счета.

Ведущий | C4 | Канал 5 адреса.

| C6 | Канал 5 счета.

| C8 | Канал 6 адреса.

| CA | Канал 6 счета.

| CC | Канал 7 адреса.

| CE | Канал 7 счета.

Адреса портов для регистров управления.

Адрес | Операция| Функция.

DMAC1 DMAC2 | |

------------+---------+-----------------------------------

0A D4 | Запись | регистр маски.

0B D6 | Запись | регистр режима.

0C D8 | Запись | регистр сброс байта flip-flop.

Адреса портов для младших регистров страницы.

Адрес | Функция.

--------+-----------------------------------

81 | 2 Канал DMA с 8 битами.

82 | 3 Канал DMA с 8 битами.

83 | 1 Канал DMA с 8 битами.

87 | 0 Канал DMA с 8 битами.

89 | 6 Канал DMA с 16 битами.

8A | 7 Канал DMA с 16 битами.

8B | 5 Канал DMA с 16 битами.

Бита регистра режима.

БИТ | Функция.

---------+----------------------------------

Биты 7:6 | Биты выбора Режима.

00 | Выбранный Режим запроса.

01 | Одиночный выбранный режим.

10 | Выбранный блочный режим.

11 | Каскадный выбранный режим.

---------+----------------------------------

Бит 5 | Бит приращения / декремента Адреса.

1 | Выбранный Декремент адреса.

0 | Выбранное Приращение адреса.

---------+----------------------------------

Бит 4 | Авто инициализация.

1 | Автоинициализация включена.

0 | Одиночный.

---------+----------------------------------

Биты 3:2 | Биты Пересылки.

00 | Проверите пересылку.

01 | Запишите пересылку ( К памяти ).

10 | Читайте пересылку ( Из памяти ).

11 | Запрещенный.

** | Игнорируется если биты 7:6 = 11.

---------+----------------------------------

Биты 1:0 | Биты выбора Канала.

00 | Выберите канал 0 (4).

01 | Выберите канал 1 (5).

10 | Выберите канал 2 (6).

11 | Выберите канал 3 (7).

Биты маски записи.

БИТ | Функция.

----------+-----------------------------------

Биты 7:3 | Неиспользуемый ( Набор к 0 ).

|

Бит 2 | Установить/сбросить бит маски.

1 | Установить бит маски ( Отключите канал ).

0 | Сбросить бит маски ( Доступен канал ).

----------+------------------------------------

Биты 1:0 | Биты выбора Канала.

00 | канал 0 (4).

01 | канал 1 (5).

10 | канал 2 (6).

11 | канал 3 (7).

DMAC2 используется для работы с 16 битами и DMAC1 используется для.

Работы с 8 битами. Вот пример программирования DMA:

1) Вычислите абсолютный линейный адрес вашего буфера.

LinearAddr = MK_SEG( Buf ) * 16L + MK_OFF ( Buf );

2) Отключите канал DMA звуковой платы установкой бита маски.

Outp(MaskPort, 1 + ( DMAChannel % 4 ));

3) Очистите указатель байта flip-flop.

Outp(ClrPort, DMAChannel );

4) Запишите режим DMA для пересылки.

Биты выбора режима должны устанавливаться в 00h для режима запроса.

Адрес бита +/- должен устанавливаться в 0 для приращения адреса.

Бит автоинициализации должен устанавливаться соответственно.

Биты пересылки должны устанавливаться в 10h для воспроизведения и.

01h для записи. Выбор канала должен устанавливаться так же как и на.

Канал DMA звуковой платы.

Outp(ModePort, Mode + ( DMAChannel % 4 ));

Некоторые часто используемые режимы:

48h + Канал - одиночный цикл воспроизведение.

58h + Канал - автоинициализируемое воспроизведение.

44h + Канал - запись одиночного цикла.

54h + Канал - автоинициализируемая запись.

5) Запишите смещение буфера, младший байт затем старший байт. Для.

Шестнадцати разрядных данных, смещение должно быть в словах от начала.

128k-байтной страницы, для 8-битных от 64K. Самый простой метод для.

Вычисления смещения с 16 битами - это разделить линейный адрес на.

Два перед вычислением смещения.

#define lo(value) (unsigned char)((value) & 0x00FF).

#define hi(value) (unsigned char)((value) >> 8).

If ( SixteenBit==1 ).

BufOffset= ( LinearAddr / 2 ) % 65536;

Else BufOffset= LinearAddr % 65536;

Outp(BaseAddrPort, lo(BufOffset));

Outp(BaseAddrPort, hi(BufOffset));

6) Запишите длину пересылки в соответствующий порт счета, младший.

Байт затем старший байт. Для пересылки с 8 битами, запишите.

Длину в байтах минус единица. Для пересылки с 16 битами, запишите.

Номер длину в словах минус единица.

If ( SixteenBit==1 ).

TransferLength/=2;

Outp(CountPort, lo(TransferLength-1));

Outp(CountPort, hi(TransferLength-1));

7) Запишите страницу буфера в регистр страницы DMA.

Outp(PagePort, ( LinearAddr / 65536));

8) Включите DMA звуковой платы очистив соответствующий бит маски.

Outp(MaskPort, DMAChannel % 4);

Пример :

Int MaskPort, ClrPort, ModePort, ModeDMA, CountPort, PagePort,

BaseAddrPort;

Int pageports[4]={ 0x87, 0x83, 0x81, 0x82 };

MaskPort=0x0A; ClrPort=0xC; ModePort=0xB;

ModeDMA=0x48+DMAChannel;

CountPort=1+DMAChannel*2;

BaseAddrPort=DMAChannel*2;

PagePort=pageports[DMAChannel];

Outportb(MaskPort, 4 + DMAChannel);

Outportb(ClrPort, DMAChannel );

Outportb(ModePort, ModeDMA );

Outportb(BaseAddrPort,lo(aligned_physical));

Outportb(BaseAddrPort,hi(aligned_physical));

Outportb(PagePort,(unsigned char)((aligned_physical>>16)&0xFF));

Outportb(CountPort,lo(len-1));

Outportb(CountPort,hi(len-1));

Outportb(MaskPort, DMAChannel );

+---------------------------+------------------------------------------------

| Установка частоты выборки |

+===========================+

Для версии Sound Blaster ниже 4.00 установка частоты выборки выполняется.

Посылкой DSP команды 40h. При этом частота преобразуется к константе времени.

По формуле:

4KHz - > 23 KHz:

Time Constant = 256 - (1,000,000 / sampling rate).

= 256 - (1,000,000 / 8,000 ).

= 131.

4KHz - > 44 KHz:

Time Constant = (MSByte of) 65536 - (256,000,000 / sampling rate).

= (MSByte of) 65536 - (256,000,000 / 44,100).

= (MSByte of) 59731.

= (MSByte of) 0E953h.

= 0E9h.

Void pascal RateSB.

( unsigned int rate ).

{

Unsigned char tc;

If ( MaxFrequency==0 ).

{

If ( rate<5000 ) rate=5000;

If ( rate>22528 ) rate=22528;

Tc = (unsigned char)(256 - (1000000/rate));

}

Else.

{

If ( rate<5000 ) rate=5000;

If ( rate>45056 ) rate=45056;

Tc = (unsigned char)(hi((unsigned int)(65536-(256000000L/rate))));

}

WriteSB(TIME_CONSTANT);

WriteSB(tc);

}

В отличие от этого SB16 программируется фактической частотой выборки.

Команда 41h используется для воспроизведения, а 42h используется для записи.

If ( Play==1 ).

WriteSB ( 0x41 );

Else WriteSB ( 0x42 );

WriteSB ( hi( frequency ) );

WriteSB ( lo( frequency ) );

+---------------------------------------+------------------------------------

| Алгоритм цифрового ввода/вывода звука |

+=======================================+

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

Последовательность:

1) Распределите буфер который не пересекает границу 64 Kb.

2) Установите программу обработки прерывания.

3) Запрограммируйте контроллер DMA для фоновой пересылки.

4) Установите частоту выборки.

5) Запишите команду I/O в DSP.

6) Запишите режим пересылки I/O в DSP.

7) Запишите размер блока в DSP ( Младший байт/Старший байт ).

После этого сразу начнется запись или воспроизведение звука.

Выделение памяти под буфер DMA:

Data=(char far *)farmalloc(131000L);

If ( data==NULL ).

{

Printf("Нет места под буфер DMA\n");

Return 0;

}

Physical=((unsigned long)FP_OFF(data))+(((unsigned long)FP_SEG(data))<<4);

Aligned_physical=physical+0x0FFFFL;

Aligned_physical&=0xF0000L;

Aligned=MK_FP((unsigned )((aligned_physical >> 4) & 0xFFFF),0);

Ниже приведены примеры последовательностей для программирования SB.

С помощью DMA.

Нормальная частота, воспроизведение:

1) Записать D1h в 2xCh.

2) Установить обработчик прерывания.

3) Записать 40h в 2xCh.

4) Записать константы времени в 2xCh.

5) Запрограммировать DMA.

6) Записать 14h в 2xCh.

7) Записать длину выборки.

8) Обслуживать прерывания, до окончания выборки.

9) Восстановить старый обработчик.

10) Записать D3h в 2xCh.

При этом можно записывать любые команды в DSP, пока идет воспроизведение.

Повышенная частота, воспроизведение:

1) Записать D1h в 2xCh.

2) Установить обработчик прерывания.

3) Записать 40h в 2xCh.

4) Записать константы времени в 2xCh.

5) Запрограммировать DMA.

6) Записать 48h в 2xCh.

7) Записать длину выборки.

8) Записать 91h в 2xCh.

9) Обслуживать прерывания, до окончания выборки.

10) Восстановить старый обработчик.

11) Записать D3h в 2xCh.

Нормальная частота, запись звука:

1) Установить обработчик прерывания.

2) Записать 40h в 2xCh.

3) Записать константы времени в 2xCh.

4) Запрограммировать DMA.

5) Записать 24h в 2xCh.

6) Записать длину выборки.

7) Обслуживать прерывания, до окончания выборки.

8) Восстановить старый обработчик.

При этом можно посылать любые команды в DSP, пока идет запись.

Повышенная частота, запись:

1) Установить обработчик прерывания.

2) Записать 40h в 2xCh.

3) Записать константы времени в 2xCh.

4) Запрограммировать DMA.

5) Записать 48h в 2xCh.

6) Записать длину выборки.

7) Записать 99h в 2xCh.

8) Обслуживать прерывания, до окончания выборки.

9) Восстановить старый обработчик.

+------------------------------------+--------------------------------------

| Конец цифрового ввода/вывода звука |

+====================================+

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

Прерывания зависит от установки IRQ на плате Sound Blaster:

IRQ | Прерывание.

-----+------------

2 | 0Ah.

3 | 0Bh.

5 | 0Dh.

7 | 0Fh.

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

1) подтвердите прием прерывания от DSP прочитав порт (2xEh) один раз для.

8-битного звука, или порт 2xF для 16-битного звука.

2) Вывод следующего буфера, если есть.

3) Выведите значение 20h ( EOI ) в порт контроллера прерывания 20h,

А если IRQ8-15(прерывания 70h-77h), то записать 20h в A0h.

Установка прерывания :

DMA_complete = 0;

Disable();

OldIRQ = getvect(0x08 + SbIRQ);

Setvect(0x08 + SbIRQ,SBHandler);

Enable();

Обработчик прерывания :

Static void far interrupt SBHandler( void ).

{

Enable();

DMA_complete = 1;

// подтведить.

Inportb(baseAddrSB+0xE);

Outportb(0x20,0x20);

}

Инициализация обработчика :

DMA_complete = 0;

Im = inportb(0x21);

Tm = ~(1 << SbIRQ);

Outportb(0x21,im & tm);

Enable();

Сброс обработчика :

Disable();

Setvect(0x08 + SbIRQ,OldIRQ);

I = inportb(0x21);

Outportb(0x21, i | (1 << SbIRQ));

Enable();

Воспроизведение файла выборки:

F = fopen(argv[1],"rb");

Raw = ( char far * ) farmalloc(32000L);

If ( f == 0 || raw==0 ).

{

Printf("Не могу открыть файл выборки - %s\n",argv[1]);

Printf("Нет памяти\n",argv[1]);

ResetSB();

Return;

}

Printf("Воспроизведение выборки ...\n");

WriteSB(ON_SOUND_SB);

RateSB(22222);

Len=fread(raw,1,32000,f);

While ( 1 ).

{

If ( len==0 ) break;

PlaySB(raw,len);

Len=fread(raw,1,32000,f);

While ( StatePlaySB()==0 ).

If ( kbhit() ) { getch(); goto Fin; }.

}

Fin:

If ( f!=0 ) fclose(f);

If ( raw!=0 ) farfree(raw);

ResetSB();

+-------------+-------------------------------------------------------------

| Стерео звук |

+=============+

При воспроизведении стерео звуков необходимо посылать 2 байта DSP, первый.

Для левого канала, второй для правого. Необходимо так же указать SB,

Что вы воспроизводите стерео звук, через регистры миксера.

+----------------------+----------------------------------------------------

| Миксер Sound Blaster |

+======================+

Ниже приведена информация для SbPro.

Порт 2x4h - индексный порт миксера, 2x5h - порт данных (чтения/записи).

Void pascal WriteMixerSB.

( char index, char val ).

{

Outportb(baseAddrSB+4,index);

Outportb(baseAddrSB+5,val);

}

Char pascal ReadMixerSB.

( char index ).

{

Outportb(baseAddrSB+4,index);

Return inportb(baseAddrSB+5);

}

Регистр Сброса Данных используется для инициализации миксера. Установите.

Этот регистр в 0 перед изменением любого из других регистров миксера.

Void pascal ResetMixerSB.

( void ).

{

WriteMixerSB(0,0); // RESET.

}

Регистр записи определяет источник звука и тип фильтра.

Индекс = 0Ch.

7 6 5 4 3 2 1 0.

--------+-------+---+---+----

+---+---+ +-+-+

+---+ |

| |

В Фильтре ADC Источник.

000 - Низкие 00 - Микрофон 1.

001 - Высокие 01 - CD.

010 - Нет Фильтра 10 - Микрофон 2.

11 - Линейный вход.

#define SOURCE_MIC1 0.

#define SOURCE_CD 1.

#define SOURCE_MIC2 2.

#define SOURCE_LINE 3.

Void pascal InputMixerSB.

( char sou, char filtr ).

{

Char val;

Val=(sou<<1)&0x6;

Val|=(filtr<<3)&0x38;

WriteMixerSB(0xC,val);

}

Регистр воспроизведения служит для установки фильтра и стерео звука.

Индекс = 0Eh.

7 6 5 4 3 2 1 0.

--------+---------------+----

| |

| |

0 - Использовать фильтр 0 - моно.

1 - Без фильтра 1 - Stereo.

#define MONO 0.

#define STEREO 1.

#define USE_FILTER 0.

#define BYPASS_FILTER 1.

Void pascal OutputMixerSB.

( char st, char filtr ).

{

Char val;

Val=(st==1)?2:0;

Val|=(filtr==1)?0x20:0;

WriteMixerSB(0xE,val);

}

Регистр общей громкости:

Индекс = 22h.

7 6 5 4 3 2 1 0.

+-----------+---+-----------+

+-----+-----+ +-----+-----+

| |

Громкость Громкость.

Лево Право.

Void pascal MasterVolumeSB.

( char left, char right ).

{

Char val;

Val=right&0xf;

Val|=(left<<4)&0xf0;

WriteMixerSB(0x22,val);

}

Регистр громкости DSP:

Индекс = 04h.

7 6 5 4 3 2 1 0.

+-----------+---+-----------+

+-----+-----+ +-----+-----+

| |

Громкость Громкость.

Лево Право.

Void pascal VoiceVolumeSB.

( char left, char right ).

{

Char val;

Val=right&0xf;

Val|=(left<<4)&0xf0;

WriteMixerSB(0x04,val);

}

Регистр громкости FM синтезатора:

Индекс= 26h.

7 6 5 4 3 2 1 0.

+-----------+---+-----------+

+-----+-----+ +-----+-----+

| |

Громкость Громкость.

Лево Право.

Void pascal FMVolumeSB.

( char left, char right ).

{

Char val;

Val=right&0xf;

Val|=(left<<4)&0xf0;

WriteMixerSB(0x26,val);

}

Регистр громкости CD:

Индекс = 28h.

7 6 5 4 3 2 1 0.

+-----------+---+-----------+

+-----+-----+ +-----+-----+

| |

Громкость Громкость.

Лево Право.

Void pascal CDVolumeSB.

( char left, char right ).

{

Char val;

Val=right&0xf;

Val|=(left<<4)&0xf0;

WriteMixerSB(0x28,val);

}

Регистр громкости линейного входа:

Индекс = 2Eh.

7 6 5 4 3 2 1 0.

+-----------+---+-----------+

+-----+-----+ +-----+-----+

| |

Громкость Громкость.

Лево Право.

Void pascal LineVolumeSB.

( char left, char right ).

{

Char val;

Val=right&0xf;

Val|=(left<<4)&0xf0;

WriteMixerSB(0x2E,val);

}

Регистр громкости микрофона:

Индекс = 0Ah.

7 6 5 4 3 2 1 0.

--------------------+-------+

+---+---+

|

Громкость микрофона.

Void pascal MicVolumeSB.

( char vol ).

{

Char val;

Val=vol&0x7;

WriteMixerSB(0xA,val);

}

+------------+--------------------------------------------------------------

| Примечание:|

+============+

Данный документ составлен Анисимовым С.Ю. 08/1995. г. К-Чепецк,

Кировской обл. Россия. v1.( и последняя ).

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

Из различных источников. Поэтому автор не несет ответственность.

За неверную информацию, и за повреждения техники и тел при.

Использовании этого документа.

С наилучшими пожеланиями, для всех любителей программировать Sound Blaster !

Vale !

©Drkb::02257.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как разбить цвет на составляющие и наоборот?

GetRValue.

GetBValue.

GetGValue.

В обратную сторону RGB().

©Drkb::03675.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Пример работы с DrawIcon(Ex).

Code: DrawIcon(Canvas.Handle, 5, 5, Application.Icon.Handle); DrawIconEx(Canvas.Handle, 40, 40, Application.Icon.Handle, 0, 0, 0, Canvas.Brush.Handle, DI_NORMAL);

Как сделать регулятор громкости?

ВОТ нашел в Интернете:

Эта программа увеличивает громкость выбранного канала на 1000.

Code: Uses MMSystem; Procedure TForm1.Button1Click(Sender: TObject); Var. Vol: longint; LVol, RVol: integer; Begin. AuxGetVolume(ListBox1.ItemIndex, @Vol); LVol := Vol shr 16; If LVol < MaxWord - 1000. Then LVol := LVol + 1000. Else LVol := MaxWord; RVol := (Vol shl 16) shr 16; If RVol < MaxWord - 1000. Then RVol := RVol + 1000. Else RVol := MaxWord; AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol); End; Procedure TForm1.FormCreate(Sender: TObject); Var. I: integer; Cap: TAuxCaps; Begin. For i := 0 to auxGetNumDevs - 1 do begin. AuxGetDevCaps(i, Addr(cap), SizeOf(cap)); ListBox1.Items.Add(cap.szPname). End; End;

Как вывести текст, написанный под углом или вращение текста.

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

Code: Procedure TForm1.FormPaint(Sender: TObject); Var. Lf: TLogFont; Begin. FillChar(lf, SizeOf(lf), 0); With lf do begin. // Высота буквы. LfHeight := 15; // Ширина буквы. LfWidth := 20; // Угол наклона в десятых градуса. LfEscapement := 100; // Жирность 0..1000, 0 - по умолчанию. LfWeight := 1000; // Курсив. LfItalic := 0; // Подчеркнут. LfUnderline := 1; // Зачеркнут. LfStrikeOut := 1; // CharSet. LfCharSet := RUSSIAN_CharSet; // Название шрифта. StrCopy(lfFaceName, 'Arial'); End; With Form1.Canvas do begin. FillRect(ClipRect); Font.Handle := CreateFontIndirect(lf); TextOut(0, 100, 'It is a text string'); End; End;

©Drkb::03637.

Автор: Pegas.

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: { Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }. { Шрифт должен быть TrueType ! }. Procedure CanvasSetTextAngle(c: TCanvas; d: single); Var LogRec: TLOGFONT; { Информация о шрифте }. Begin. {Читаем текущюю инф. о шрифте }. GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) ); { Изменяем угол }. LogRec.lfEscapement := round(d*10); { Устанавливаем новые параметры }. C.Font.Handle := CreateFontIndirect(LogRec); End;

©Drkb::03638.

Зайцев О.В.

Владимиров А.М.

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

Code: Procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string); Var hFont, Fontold: integer; DC: hdc; Fontname: string; Begin. If length(txt)= 0 then. EXIT; DC:= Screen.ActiveForm.Canvas.handle; SetBkMode(DC, transparent); Fontname:= Screen.ActiveForm.Canvas.Font.Name; HFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0, 0,1,4,$10,2,4,PChar(Fontname)); Fontold:= SelectObject(DC, hFont); TextOut(DC,x,y,PChar(txt), length(txt)); SelectObject(DC, Fontold); DeleteObject(hFont); End;

Как работать с GIF файлами?

Code: Procedure TForm1.Button2Click(Sender: TObject); Begin. If opendialog1.Execute then. Begin. ListBox1.Items := opendialog1.Files; Edit2.Text := inttostr(ListBox1.Items.Count); End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. I, a: integer; Bm: TBItmap; Begin. A := 0; Bm := TBItmap.Create; Image1.Picture.LoadFromFile(listbox1.Items[0]); Bm.Height := image1.Height; Bm.Width := listbox1.Items.Count * image1.Picture.width; For i := 0 to listbox1.Items.Count - 1 do. Begin. Image1.Picture.LoadFromFile(listbox1.Items[i]); Bm.Canvas.Draw(a, 0, image1.Picture.Graphic); A := a + image1.Picture.Height; End; //form1.Canvas.Draw(0,0,bm); Bm.SaveToFile(Edit1.Text + '.bmp'); Bm.free; End;

Как получить hex-значение данного цвета?

GetRValue, GetGValue, GetBValue - дадут тебе байты цветов, затем тебе надо их перевести в hex...

©Drkb::03668.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

IntToHex(Color);

Автор ответа: neutrino.

©Drkb::03669.

Взято с Vingrad.ru http://forum.vingrad.ru.

В модуле graphics имеются две недокументированные функции:

Function ColorToString(Color: TColor): string;

Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.

Function StringToColor(S: string): TColor;

Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.

©Drkb::03670.

Автор: Pegas.

Взято с Vingrad.ru http://forum.vingrad.ru.

O сохранении иконок 32хЗ2 в 256-цветном формате.

Высылаю Вам информацию для FAQ о сохранении иконок 32хЗ2 в 256-цветном.

Формате. Распоряжайтесь ею как Вам нужно. Размер кода большой, думаю для FAQ.

Не годится, скорее для раздела "Обмен опытом", но Вам видней. И сообщите,

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

Кто обратится, все описание, а просто дать ссылку.

С уважением, Владимир, г.Иркутск, nsvi@hotbox.ru.

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

Понадобилось немного изменить имеющиеся у меня для своих программ. Ни родной.

Image Editor от Delphi6, ни другие редакторы не смогли мне помочь. Могли это.

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

Что созданная функцией CreateIconIndirect иконка нормально выглядит, если.

После создания ее кинуть на форму, однако после записи Icon.SaveToFile.

Иконка обезображивается. Это происходит на стадии записи иконки. Поискав.

Информацию, облазив форумы, я понял, что либо этой проблемой никто не.

Занимался, либо с ней все мирятся и заниматься не хотят, хотя интересующиеся.

Имеются.

Став заниматься проблемой вплотную, я решил использовать нетипизированные.

Файлы, которым все равно, что в них записывают. Эти файлы хорошо подходят.

Для работы с массивами байт и, если создать массив полностью соответствующий.

Структуре иконки, то записав массив в нетипизированный файл, получим искомую.

Иконку.

Пришлось изучить структуру файла ICO и вот результат.

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

Вы не хотите ничего изменять, например, размеры иконки. В принципе, можно.

Сделать универсальную процедуру, которая бы определяла размер иконки и, в.

Соответствии с размерами, создавала иконку. Все адреса и размеры, указанные.

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

Них зависит, будет ли соответствовать создаваемый массив файлу ICO.

В процедуру введено автоопределение количества цветов палитры, от этого.

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

Цветов.

Кроме того, введено определение размера рисунка и если он не 32хЗ2, то.

Процедура прекратит работу. Это произойдет и в случае если кому-то захочется.

Использовать более 256 цветов. Тем, кто хочет узнать о структуре файлов ICO,

Читать после кода процедуры.

Используя этот метод можно работать с любыми файлами, например, для открытия.

И побайтного изменения EXE-файлов.

Для работы этой процедуры нужен рисунок 32хЗ2 на канве (у меня Image2),

Диалоговое окно SaveDialog1 (но не SavePictureDialog1).

И все. Если нужно, измените имя канвы, оно встречается в двух строчках кода,

И имя диалогового окна. Процедура с комментариями ниже:

//Записываем картинку как иконку (файл .ico).

{Так как стандартные функции не дают возможности создавать 256 цветные.

Иконки, мы пойдем другим путем, хоть он и медленнее и длиннее.

Создадим массив байт, который запишем как файл, это и будет.

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

Станет слишком навороченной, затем проверим количество используемых цветов.

И, в зависимости от этого, создадим окончательный массив.}.

Code: Procedure TForm1.ToolButton6Click(Sender: TObject); Var. MAnd, MXor, MOsn, MCol: array of Byte; MPix, MOrg: array of TColor; A, b, c, n, m: integer; Bt, Bu, Indicator: Byte; P: TColor; K: boolean; F: file; LenOsn, LenXor, LenCol: integer; Begin. If (Image2.Picture.Height <> 32) or (Image2.Picture.Width <> 32) then. Begin. ShowMessage('Исходный рисунок не 32хЗ2'); Exit; End; {Создание массивов: MAnd - массив маски AND, MXor - массив маски Xor, Основного массива MOsn - куда будет собираться вся информация, Массив MPix - массив пикселов рисунка начиная с левого нижнего угла, MCol - массив таблицы цветов - палитры, MOrg - массив оригинальных цветов}. {Заполнение массивов MPix и MAnd}. {Активизация массивов}. SetLength(MPix, 1024); SetLength(MAnd, 128); {Установка счетчиков}. B := 0; //Счетчик битов. A := 0; //Счетчик пикселов картинки. C := 0; //Счетчик байтов маски MAnd. Bt := 0; //Формируемый байт маски MAnd. {Преобразование картинки в удобный формат, с началом от 0, И перенос ее в таком виде в массив MPix, меняя по пути белый - Будущий прозрачный цвет - на черный, заодно заполняем массив MAnd}. For m := 31 downto 0 do. For n := 0 to 31 do. Begin. MPix[a] := Image2.Canvas.Pixels[n, m]; P := MPix[a]; If p = RGB(255, 255, 255) then. Begin. MPix[a] := RGB(0, 0, 0); If b = 0 then. Bt := Bt + 128; If b = 1 then. Bt := Bt + 64; If b = 2 then. Bt := Bt + 32; If b = 3 then. Bt := Bt + 16; If b = 4 then. Bt := Bt + 8; If b = 5 then. Bt := Bt + 4; If b = 6 then. Bt := Bt + 2; If b = 7 then. Bt := Bt + 1; End; B := b + 1; If b = 8 then. Begin. MAnd[c] := Bt; Bt := 0; C := c + 1; B := 0; End; A := a + 1; End; {Заполнение маски MOrg нулями, предполагая 256 цветов}. SetLength(MOrg, 256); For n := 0 to 255 do. MOrg[n] := RGB(255, 255, 255); {Оцениваем количество цветов и от результата переделываем MOrg}. A := 0; //Счетчик количества цветов. For n := 0 to 1023 do. Begin. P := MPix[n]; K := false; For m := 0 to 255 do. Begin. If k = false then. If p = MOrg[m] then. K := true; End; If k = false then. Begin. If a > 255 then. Begin. ShowMessage('Ваш рисунок имеет более 256 цветов'); MOrg := nil; MPix := nil; MAnd := nil; Exit; End; MOrg[a] := p; A := a + 1; End; End; LenOsn := 2238; LenXor := 1024; LenCol := 1024; Indicator := 1; If a < 15 then. Begin. LenOsn := 766; LenXor := 512; Indicator := 0; End; {Заполняем маски нулями}. SetLength(MXor, LenXor); SetLength(MCol, LenCol); For n := 0 to LenXor - 1 do. Begin. MXor[n] := 0; End; For n := 0 to LenCol - 1 do. Begin. MCol[n] := 0; End; {Заполнение массива MXor согласно массива MPix}. Bu := 0; B := 0; C := 0; For n := 0 to 1023 do. Begin. P := MPix[n]; K := false; For Bt := 0 to 255 do. Begin. If k = false then. If p = MOrg[Bt] then. Begin. K := true; If indicator = 1 then. MXor[n] := Bt. Else if b = 1 then. Begin. Bu := 16 * Bu + Bt; MXor[c] := Bu; C := c + 1; B := 0; End. Else. Begin. Bu := Bt; B := 1; End; End; End; End; {Заполняем массив MCol согласно массива MOrg}. Begin. A := 0; For n := 0 to 255 do. Begin. P := MOrg[n]; MCol[a] := GetBValue(p); MCol[a + 1] := GetGValue(p); MCol[a + 2] := GetRValue(p); A := a + 4; End; End; {Заполняем MOsn нулями}. SetLength(MOsn, LenOsn); For n := 0 to LenOsn - 1 do. MOsn[n] := 0; {Заполняем массив MOsn для 256 цветной иконки}. If indicator = 1 then. Begin. MOsn[2] := 1; MOsn[4] := 1; MOsn[6] := 32; MOsn[7] := 32; MOsn[14] := $A8; MOsn[15] := 8; MOsn[18] := $16; MOsn[22] := $28; MOsn[26] := 32; MOsn[30] := $40; MOsn[34] := 1; MOsn[36] := 8; MOsn[42] := $80; MOsn[43] := 4; MOsn[55] := 1; M := 0; For n := 62 to 1085 do. Begin. MOsn[n] := MCol[m]; M := m + 1; End; M := 0; For n := 1086 to 2109 do. Begin. MOsn[n] := MXor[m]; M := m + 1; End; M := 0; For n := 2110 to 2237 do. Begin. MOsn[n] := MAnd[m]; M := m + 1; End; End; {Заполняем массив MOsn для 16-цветной}. If indicator = 0 then. Begin. MOsn[2] := 1; MOsn[4] := 1; MOsn[6] := 32; MOsn[7] := 32; MOsn[8] := 4; MOsn[14] := $E8; MOsn[15] := 2; MOsn[18] := $16; MOsn[22] := $28; MOsn[26] := 32; MOsn[30] := 64; MOsn[34] := 1; MOsn[36] := 4; MOsn[43] := 2; MOsn[54] := 16; M := 0; For n := 62 to 125 do. Begin. MOsn[n] := MCol[m]; M := m + 1; End; M := 0; For n := 126 to 637 do. Begin. MOsn[n] := MXor[m]; M := m + 1; End; M := 0; For n := 638 to 765 do. Begin. MOsn[n] := MAnd[m]; M := m + 1; End; End; {Закрываем все массивы, кроме MOsn}. MAnd := nil; MXor := nil; MOrg := nil; MCol := nil; MPix := nil; {Записываем массив MOsn в файл, для этого создаем нетипизированный файл, Активизируем его и побайтно пишем в него данные из массива MOsn}. If SaveDialog1.Execute then. Begin. AssignFile(f, SaveDialog1.FileName + '.ico'); Rewrite(f, 1); For n := 0 to LenOsn - 1 do. Begin. Bt := MOsn[n]; BlockWrite(f, Bt, 1); End; CloseFile(f); MOsn := nil; End; End;

Как сделать выделение "резиновым прямоугольником"?

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

В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает координаты прямоугольника sel по координатам двух протвоположенных углов прямоугольника, вне зависимости от порядка. DrawRect рисует на форме прямоугольник, использую режим XOR. Благодаря этому режиму, чтобы стереть такой прямоугольник, достаточно нарисовать его повторно.

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/.

Code: Uses stdctrls; Var. Selecting: boolean = false; FirstPoint: TPoint; Sel: TRect; Procedure DrawRect; Begin. With Form1.Canvas do begin. Pen.Style := psDot; Pen.Color := clGray; Pen.Mode := pmXor; Brush.Style := bsClear; Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom); End; End; Procedure NormalRect(p1, p2: TPoint); Begin. If p1.x < p2.x then. Begin. Sel.Left := p1.x; Sel.Right := p2.x; End. Else. Begin. Sel.Left := p2.x; Sel.Right := p1.x; End; If p1.y < p2.y then. Begin. Sel.Top := p1.y; Sel.Bottom := p2.y; End. Else. Begin. Sel.Top := p2.y; Sel.Bottom := p1.y; End; End; Procedure TForm1.FormCreate(Sender: TObject); Var i: integer; Begin. Randomize; For i := 1 to random(5) + 5 do. Begin. With TLabel.Create(Form1) do. Begin. Caption := 'Label' + IntToStr(i); Left := random(Form1.ClientWidth - Width); Top := random(Form1.ClientHeight - Height); Visible := true; Parent := Form1; End; End; End; Procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If selecting or (Button <> mbLeft) then Exit; SetCapture(Form1.Handle); Selecting := true; FirstPoint := Point(X, Y); Sel := Bounds(X, Y, 0, 0); End; Procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Procedure SelectLebel(lb: TLabel; r: TRect); Var. Select: boolean; Res: TRect; Begin. Select := IntersectRect(res, lb.BoundsRect, r); If select and (lb.Color = clNavy) then Exit; If select then. Begin. Lb.Color := clNavy; Lb.Font.Color := clWhite; End. Else. Begin. Lb.Color := clBtnFace; Lb.Font.Color := clBlack; End; End; Var i: integer; Begin. If not Selecting then Exit; DrawRect; NormalRect(FirstPoint, Point(X, Y)); For i := 0 to Form1.ComponentCount - 1 do. If (Form1.Components[i] is TLabel) then. SelectLebel(Form1.Components[i] as TLabel, sel); Application.ProcessMessages; DrawRect; End; Procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If (not Selecting) or (Button <> mbLeft) then Exit; NormalRect(FirstPoint, Point(X, Y)); DrawRect; ReleaseCapture; Selecting := false; End;

Пример работы чтения и сохранении wav-файлов.

Сразу оговорюсь, что рассматривать я буду только PCM формат - самый простой. Wav-файл состоит из заголовка и собственно информации. В заголовке находится информация о типе файла, частоте, каналах и т.д. Сама информация состоит из массива чисел по 8 или 16 бит. Если в файле 2 канала, то значения левого и правого каналов записываются поочередно.

Для работы с заголовком удобнее всего использовать запись, расположение полей в которой будет повторять расположение информации в файле. Например, первая запись в wav-файле - это символы "RIFF". Соответственно, первое поле в записи должно быть массивом из четырех элементов типа char. Вторая запись - длина файла без 8 байт (без первых двух записей). Длина записана в четырех байтах целым числом. Поэтому взят тип longint. Так составляется эта запись. Когда нужно целое число длиной 2 байта - берется smallint.

О создании wav-файлов и хранении самой информации я расскажу в следующем выпуске.

Эта программа выводит в Memo длину wav-файла, количество каналов, частоту и количество бит на запись.

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

Code: Type. TWaveHeader = record. IdRiff: array[0..3] of char; RiffLen: longint; IdWave: array[0..3] of char; IdFmt: array[0..3] of char; InfoLen: longint; WaveType: smallint; Ch: smallint; Freq: longint; BytesPerSec: longint; Align: smallint; Bits: smallint; End; TDataHeader = record. IdData: array[0..3] of char; DataLen: longint; End; // Процедура ?тения заголовка wav-файлов. Procedure ReadWaveHeader(Stream: TStream; Var SampleCount, SamplesPerSec: integer; Var BitsPerSample, Channeles: smallint); Var. WaveHeader: TWaveHeader; DataHeader: TDataHeader; Begin. Stream.Read(WaveHeader, sizeof(TWaveHeader)); With WaveHeader do. Begin. If idRiff <> 'RIFF' then raise EReadError.Create('Wrong idRIFF'); If idWave <> 'WAVE' then raise EReadError.Create('Wrong idWAVE'); If idFmt <> 'fmt ' then raise EReadError.Create('Wrong idFmt'); If WaveType <> 1 then raise EReadError.Create('Unknown format'); Channeles := Ch; SamplesPerSec := Freq; BitsPerSample := Bits; Stream.Seek(InfoLen - 16, soFromCurrent); End; Stream.Read(DataHeader, sizeof(TDataHeader)); If DataHeader.idData = 'fact' then. Begin. Stream.Seek(4, soFromCurrent); Stream.Read(DataHeader, sizeof(TDataHeader)); End; With DataHeader do. Begin. If idData <> 'data' then raise EReadError.Create('Wrong idData'); SampleCount := DataLen div (Channeles * BitsPerSample div 8). End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. OpenDialog1.Filter := 'Wave files|*.wav'; End; Procedure TForm1.Button1Click(Sender: TObject); Var. F: TFileStream; SampleCount, SamplesPerSec: integer; BitsPerSample, Channeles: smallint; Begin. // Вызов OpenDialog1: If not OpenDialog1.Execute then Exit; Try. // Открытие файла: F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead); // Чтение заголовка: ReadWaveHeader(F, SampleCount, SamplesPerSec, BitsPerSample, Channeles); F.Free; Memo1.Clear; // Заполнение Memo информацией о файле: Memo1.Lines.Add('SampleCount: ' + IntToStr(SampleCount)); Memo1.Lines.Add(Format('Length: %5.3f sec', [SampleCount / SamplesPerSec])); Memo1.Lines.Add('Channeles: ' + IntToStr(Channeles)); Memo1.Lines.Add('Freq: ' + IntToStr(SamplesPerSec)); Memo1.Lines.Add('Bits: ' + IntToStr(BitsPerSample)); Except. Raise Exception.Create('Problems with file reading'); End; End;

Как преобразовать текст в иконку?

Code: Unit unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Timer1: TTimer; Image1: TImage; Procedure Button1Click(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. Function StringToIcon(const st: string): HIcon; Public. { Public declarations }. End; Var. Form1: TForm1; Sss: Integer = 0; Implementation. {$R *.DFM}. Type. ICONIMAGE = record. Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов. LpBits: PChar; // указатель на DIB биты. DwNumBytes: DWORD; // Сколько байт? Lpbi: PBitmapInfoHeader; // указатель на заголовок. LpXOR: PChar; // указатель на XOR биты изображения. LpAND: PChar; // указатель на AND биты изображения. End; Function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource: BITMAPINFO): boolean; Var. Dc: HDC; HPal: HPALETTE; Pe: array[0..255] of PALETTEENTRY; I: Integer; Begin. Result := False; Case (lpTarget.bmiHeader.biBitCount) of. 8: If lpSource.bmiHeader.biBitCount = 8 then. Begin. Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD)); Result := True. End. Else. Begin. Dc := GetDC(0); If dc <> 0 then. Try. HPal := CreateHalftonePalette(dc); If hPal <> 0 then. Try. If GetPaletteEntries(hPal, 0, 256, pe) <> 0 then. Begin. For i := 0 to 255 do. Begin. LpTarget.bmiColors[i].rgbRed := pe[i].peRed; LpTarget.bmiColors[i].rgbGreen := pe[i].peGreen; LpTarget.bmiColors[i].rgbBlue := pe[i].peBlue; LpTarget.bmiColors[i].rgbReserved := pe[i].peFlags. End; Result := True. End. Finally. DeleteObject(hPal). End. Finally. ReleaseDC(0, dc). End. End; 4: If lpSource.bmiHeader.biBitCount = 4 then. Begin. Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD)); Result := True. End. Else. Begin. HPal := GetStockObject(DEFAULT_PALETTE); If (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then. Begin. For i := 0 to 15 do. Begin. LpTarget.bmiColors[i].rgbRed := pe[i].peRed; LpTarget.bmiColors[i].rgbGreen := pe[i].peGreen; LpTarget.bmiColors[i].rgbBlue := pe[i].peBlue; LpTarget.bmiColors[i].rgbReserved := pe[i].peFlags. End; Result := True. End. End; 1: Begin. I := 0; LpTarget.bmiColors[i].rgbRed := 0; LpTarget.bmiColors[i].rgbGreen := 0; LpTarget.bmiColors[i].rgbBlue := 0; LpTarget.bmiColors[i].rgbReserved := 0; I := 1; LpTarget.bmiColors[i].rgbRed := 255; LpTarget.bmiColors[i].rgbGreen := 255; LpTarget.bmiColors[i].rgbBlue := 255; LpTarget.bmiColors[i].rgbReserved := 0; Result := True. End; Else. Result := True. End. End; Function WidthBytes(bits: DWORD): DWORD; Begin. Result := ((bits + 31) shr 5) shl 2. End; Function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD; Begin. Result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount). End; Function DIBNumColors(const lpbi: BitmapInfoHeader): word; Var. DwClrUsed: DWORD; Begin. DwClrUsed := lpbi.biClrUsed; If dwClrUsed <> 0 then. Result := Word(dwClrUsed). Else. Case lpbi.biBitCount of. 1: result := 2; 4: result := 16; 8: result := 256. Else. Result := 0. End. End; Function PaletteSize(const lpbi: BitmapInfoHeader): word; Begin. Result := DIBNumColors(lpbi) * sizeof(RGBQUAD). End; Function FindDIBBits(const lpbi: BitmapInfo): PChar; Begin. Result := @lpbi; Result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader). End; Function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean): PBitmapInfo; Var. Lpbmi: PBITMAPINFO; LpSourceBits, lpTargetBits: Pointer; DC, hSourceDC, hTargetDC: HDC; HSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap: HBITMAP; DwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD; Begin. Result := nil; // Располагаем и заполняем структуру BITMAPINFO для нового DIB. // Обеспе?иваем достато?но места для 256-цветной таблицы. DwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD)); GetMem(lpbmi, dwTargetHeaderSize); Try. Lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER); Lpbmi^.bmiHeader.biWidth := nWidth; Lpbmi^.bmiHeader.biHeight := nHeight; Lpbmi^.bmiHeader.biPlanes := 1; Lpbmi^.bmiHeader.biBitCount := nbpp; Lpbmi^.bmiHeader.biCompression := BI_RGB; Lpbmi^.bmiHeader.biSizeImage := 0; Lpbmi^.bmiHeader.biXPelsPerMeter := 0; Lpbmi^.bmiHeader.biYPelsPerMeter := 0; Lpbmi^.bmiHeader.biClrUsed := 0; Lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов. If CopyColorTable(lpbmi^, lpSrcDIB) then. Begin. DC := GetDC(0); HTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS, LpTargetBits, 0, 0); HSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS, LpSourceBits, 0, 0); Try. If (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then. Begin. HSourceDC := CreateCompatibleDC(DC); HTargetDC := CreateCompatibleDC(DC); Try. If (hSourceDC <> 0) and (hTargetDC <> 0) then. Begin. // Flip the bits on the source DIBSection to match the source DIB. DwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader); DwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) * BytesPerLine(lpbmi^.bmiHeader); Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize); // Select DIBSections into DCs. HOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap); HOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap); Try. If (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then. Begin. // Устанавливаем таблицу цветов для DIBSections. If lpSrcDIB.bmiHeader.biBitCount <= 8 then. SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors); If lpbmi^.bmiHeader.biBitCount <= 8 then. SetDIBColorTable(hTargetDC, 0, 1 shl. Lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors); // If we are asking for a straight copy, do it. If (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then. BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY). Else if bStretch then. Begin. SetStretchBltMode(hTargetDC, COLORONCOLOR); StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, Lpbmi^.bmiHeader.biHeight, HSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight, SRCCOPY). End. Else. BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY); GDIFlush; GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize)); Move(lpbmi^, result^, dwTargetHeaderSize); Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize). End. Finally. If hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap); If hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap); End. End. Finally. If hSourceDC <> 0 then DeleteDC(hSourceDC); If hTargetDC <> 0 then. DeleteDC(hTargetDC). End. End; Finally. If hTargetBitmap <> 0 then DeleteObject(hTargetBitmap); If hSourceBitmap <> 0 then DeleteObject(hSourceBitmap); If dc <> 0 then. ReleaseDC(0, dc). End. End. Finally. FreeMem(lpbmi). End. End; Function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo; BStretch: boolean): boolean; Var. LpNewDIB: PBitmapInfo; Begin. Result := False; LpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors, BStretch); If Assigned(lpNewDIB) then. Try. Lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок. + PaletteSize(lpNewDIB^.bmiHeader) // Палитра. + lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска. + lpii.Height * WIDTHBYTES(lpii.Width); // AND маска. // Если здесь уже картинка, то освобождаем е? If lpii.lpBits <> nil then. FreeMem(lpii.lpBits); GetMem(lpii.lpBits, lpii.dwNumBytes); Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize. (lpNewDIB^.bmiHeader)); // Выравниваем внутренние указатели/переменные для новой картинки. Lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits); Lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2; Lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^); Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine. (lpNewDIB^.bmiHeader)); Lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine. (lpNewDIB^.bmiHeader); Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00); Result := True. Finally. FreeMem(lpNewDIB). End. End; Function TForm1.StringToIcon(const st: string): HIcon; Var. MemDC: HDC; Bmp: HBITMAP; OldObj: HGDIOBJ; Rect: TRect; Size: TSize; InfoHeaderSize: DWORD; ImageSize: DWORD; InfoHeader: PBitmapInfo; Icon: IconImage; OldFont: HFONT; Begin. Result := 0; MemDC := CreateCompatibleDC(0); If memDC <> 0 then. Try. Bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16); If bmp <> 0 then. Try. OldObj := SelectObject(memDC, bmp); If oldObj <> 0 then. Try. Rect.Left := 0; Rect.top := 0; Rect.Right := 16; Rect.Bottom := 16; SetTextColor(memDC, RGB(255, 0, 0)); SetBkColor(memDC, RGB(128, 128, 128)); OldFont := SelectObject(memDC, font.Handle); GetTextExtentPoint32(memDC, PChar(st), Length(st), size); ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil); SelectObject(memDC, oldFont); GDIFlush; GetDibSizes(bmp, infoHeaderSize, imageSize); GetMem(infoHeader, infoHeaderSize + ImageSize); Try. GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^); Icon.Colors := 4; Icon.Width := 32; Icon.Height := 32; Icon.lpBits := nil; If DibToIconImage(icon, infoHeader^, True) then. Try. Result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000); Finally. FreeMem(icon.lpBits). End. Finally. FreeMem(infoHeader). End. Finally. SelectObject(memDC, oldOBJ). End. Finally. DeleteObject(bmp). End. Finally. DeleteDC(memDC). End. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Application.Icon.Handle := StringToIcon('0'); Timer1.Enabled := True; Button1.Enabled := False; End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. Inc(sss); If sss > 100 then sss := 1; Application.Icon.Handle := StringToIcon(IntToStr(sss)); End; End.

Как загрузить BMP файл из DLL?

Code: Procedure TForm1.Button1Click(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var. AModule: THandle; Begin. AModule := LoadLibrary('Images.dll'); Image1.Picture.BitMap.LoadFromResourceName(AModule, 'StartMine'); FreeLibrary(AModule); End;

Как определить уровень звука в данный момент?

Единственное, что удалось найти это компонент на Дельфи (с исходным кодом) на http://www.torry.net/mixer.htm компонент называется Vumeter v.1.0. Я его не разбирал, но похоже что он опрашивает Audio Mixer Driver (или что-то подобное).

©Drkb::02253.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Я построил диограмму так:

Назначил F:= TFileStream.Create(OpenDialog1.FileName, fmOpenRead );

Затем считал заголовок Wav- SampleCount, SamplesPerSec, BitsPerSample, Channeles.

Затем считал данные- GetMem(buf, SampleCount * Channeles * BitsPerSample);

Описал массив Volume- SetLength(Volume, SampleCount);

Затем - F.Read(buf^, SampleCount*2); F.Free;

Затем заполнил массив -

Code: Buf16 := buf; For h := 0 to SampleCount - 1 do. Begin. Volume[h] := abs(buf16^); Inc(buf16); End; FreeMem(buf);

Как извлечь иконку из EXE или DLL?

Такой вот совет пришел ко мне с рассылкой "Ежедневная рассылка сайта Мастера DELPHI", думаю многим будет интересно.

Решить эту задачу нам поможет функция function ExtractIcon(hInstance, filename, iconindex):integer.

Где hinstance - глобальная переменная приложения, ее изменять не надо. Тип integer.

Filename - имя программы или DLL из которой надо извлекать иконки. Тип pchar.

Iconindex - порядковый номер иконки в файле (начинается с 0). В одном файле может находится несколько иконок. Тип integer.

Функция находится в модуле ShellApi, так что не забудьте подключить его в uses. Если эта функция возвратит ноль, значит иконок в файле нет.

Данная функция возвращает handle иконки, поэтому применять ее нужно так:

Image1.Picture.Icon.Handle:=ExtractIcon(hInstance, pchar(paramstr(0)), 0);

Данное объявление нарисует в Image'e картинку вашего приложения.

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

©Drkb::02154.

Взято с Vingrad.ru http://forum.vingrad.ru.

Функция ExtractIcon позволяет извлечь иконку из exe, dll и ico-файлов. Если указанная иконка отсутствует, функция возвращает 0. Количество иконок, содержащихся в файле, можно узнать, указав в качестве последнего параметра -1.

Code: Uses ShellAPI; Procedure TForm1.Button1Click(Sender: TObject); Var. Ic: TIcon; I, count: integer; W: integer; Begin. If OpenDialog1.Execute = false then Exit; Form1.Canvas.FillRect(Form1.Canvas.ClipRect); Count := ExtractIcon(Application.Handle, PChar(OpenDialog1.FileName), -1); Ic := TIcon.Create; W := Form1.Width div 32; For i := 0 to count - 1 do begin. Ic.Handle := ExtractIcon(Application.Handle, PChar(OpenDialog1.FileName), i); Form1.Canvas.Draw(32 * (i mod w), 32 * (i div w), ic); End; Ic.Destroy; End;

Что такое Цвет?

Если Edit1.text это String то что такое Edit1.font.color?

TColor - это Integer, чтоб задать нужный цвет можно пользовать константы, а можно в числовом виде:

Edit1.font.color:=$223344.

Где 22 - яркость красного цвета, может быть в пределах от 00 до FF.

Где 33 - яркость зеленого цвета, может быть в пределах от 00 до FF.

Где 44 - яркость синего цвета, может быть в пределах от 00 до FF.

Например:

Edit1.font.color:=$000000 - черный.

Edit1.font.color:=$FFFFFF - белый.

Edit1.font.color:=$00FF00 - зеленый.

Всего определено 256*256*256 цветов.

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

Edit1.font.color:=123456.

©Drkb::03665.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Можно использовать константы типа clred, clblack, cllime, clgreen...

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

RGB(r,g,b:byte):tcolor //получаешь цвет по 3 составляющим.

GetRValue(color:tcolor).

GetGValue(color:tcolor)//получаешь значение интенсивности цвета.

GetBValue(color:tcolor).

Автор ответа: Mikel.

Взято с Vingrad.ru http://forum.vingrad.ru.

©Drkb::03666.

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

Тип TColor состоит из четырех байт. Первый байт - указатель на замену цвета (о нем поговорим позже). Второй байт - яркость красного цвета от 0 до 255 (от 00 до FF). Третий байт - яркость зеленого цвета от 0 до 255 (от 00 до FF). И, наконец, четвертый байт - яркость синего цвета, также, от 0 до 255 (от 00 до FF).

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

Поговорим теперь о первом байте - указателе на замену цвета. Итак, этот байт может принимать три различных значения - ноль ($00), единицу ($01) или двойку ($02). Что это значит:

Ноль ($00) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из системной палитры.

Единица ($01) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из палитры, которая установлена сейчас.

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

Видимо, всегда лучше устанавливать значение первого байта равным нулю ($00), по крайней мере, так происходит при получении типа TColor при помощи функции RGB.

И, напоследок, несколько примеров:

$00FFFFFF - белый цвет;

$00000000 - черный цвет;

$00800000 - темно-красный цвет.

©Drkb::03667.

Взято с http://delphiworld.narod.ru.

Вывод надписи на рабочий стол.

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

TextOut(GetWindowDC(GetDesktopWindow),100,100,'Thom',4);

©Drkb::03648.

Автор: Fantasist.

Взято с Vingrad.ru http://forum.vingrad.ru.

Поверх всех окон можно нарисовать надпись использую следующую процедуру:

Code: Procedure WriteDC(s: string); Var c: TCanvas; Begin. C := TCanvas.Create; C.Brush.Color := clBlue; C.Font.color := clYellow; C.Font.name := 'Fixedsys'; C.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER)); C.TextOut(screen.Width - c.TextWidth(s) - 2, screen.Height - 43, s); C.free; End;

Как копировать образ экрана в файл.

На форме у меня стоит TImage (его можно сделать невидимым).

Code: Uses JPEG; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. ... Var i: TJPEGImage; Begin. Try. I := TJPEGImage.create; Try. I.CompressionQuality := 100; Image.Width := screen.width; Image.height := screen.height; DWH := GetDesktopWindow; GetWindowRect(DWH, DRect); DescDC := GetDeviceContext(DWH); Canv.Handle := DescDC; DRect.Left := 0; DRect.Top := 0; DRect.Right := screen.Width; DRect.Bottom := screen.Height; Image.Canvas.CopyRect(DRect, Canv, DRect); I.assign(Image.Picture.Bitmap); I.SaveToFile('M:\MyFile.jpg'); Finally. I.free; End; Except. End;

Работа с очень большими числами.

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

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

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

Code: Unit UMathServices; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Interface. Type TProgress = procedure(Done:real); {Собственно экспортные функции}. Function ulFact(First:String):string; Function ulSum(First, Second :string):string; Function ulSub(First, Second :string):string; Function ulMPL(First, Second :string):string; Function ulPower(First, Second :string):string; Function UlDiv(First, Second:String; Precision:integer):String; {Precision - не истинная точность а количество знаков учитываемых после запятой сверх тех которые значимы. Все знаки уже существующие в делимом и делителе в любом случае учитываются}. {Call back function for long operations}. Var OnProgress: TProgress; Implementation. Uses SysUtils; Type TMathArray=array of integer; Type TNumber=record. Int, frac:TMathArray; Sign:boolean; End; Var n1, n2:TNumber; Procedure Str2Number(s:string; var n:TNumber); Var i, j, l:integer; Begin. If s='' then. Begin. Setlength(n.int , 0); Setlength(n.frac , 0); Exit; End; L:=length(s); If s[1]='-' then. Begin. S:=copy(s,2,l); L:=l-1; N.sign:=false; End. Else. N.sign:=true; J:=pos('.', s); If j>0 then. Begin. Setlength(n.int , j-1); For i:=1 to j-1 do n.int[i-1]:=strtoint(s[j-i]); Setlength(n.frac , l-j); For i:=1 to l-j do n.frac[i-1]:=strtoint(s[l-i+1]); End. Else. Begin. Setlength(n.int,l); For i:=1 to l do n.int[i-1]:=strtoint(s[l-i+1]); Setlength(n.frac,0); End; End; Function Num2Array(Var n:TNumber; var a:TMathArray):integer; Var i:integer; Begin. Result:=length(n.frac); Setlength(a,length(n.int)+result); For i:=0 to length(a)-1 do if i<result then a[i]:=n.frac[i] else a[i]:=n.int[i-result]; End; Procedure MultiplyArray(var a1, a2, a:TMathArray); Var i, j:integer; B:boolean; Begin. {checking for zero, 1}. For i:=length(a2)-1 downto 0 do. Begin. For j:=length(a1)-1 downto 0 do. Begin. A[j+i]:=a[j+i]+(a2[i]*a1[j]); End; End; Repeat. B:=true; For i:=0 to length(a)-1 do. If a[i]>9 then. Begin. B:=false; Try. A[i+1]:=a[i+1]+1; Except. Setlength(a, length(a)+1); A[i+1]:=a[i+1]+1; End; A[i]:=a[i]-10; End; Until b; End; Procedure Array2Num(Var n:TNumber; var a:TMathArray; frac:integer; sign:boolean); Var i:integer; Begin. Setlength(n.frac,frac); Setlength(n.int,length(a)-frac); For i:=0 to length(a)-1 do. Begin. If i<frac then n.frac[i]:=a[i] else n.int[i-frac]:=a[i]; End; N.sign:=sign; End; Function Number2Str(var n:TNumber):string; Var i:integer; S:string; Begin. Result:=''; For i:=0 to high(n.int) do result:=inttostr(n.int[i])+result; If length(n.frac)<>0 then. Begin. For i:=0 to high(n.frac) do s:=inttostr(n.frac[i])+s; Result:=result+'.'+s; End; While (length(result)>1) and (result[1]='0') do delete(result,1,1); If pos('.', result)>0 then while (length(result)>1) and (result[length(result)]='0') do delete(result,length(result),1); If not n.sign then result:='-'+result; Setlength(n.int,0); Setlength(n.frac,0); End; Procedure DisposeNumber(var n:TNumber); Begin. Setlength(n.int,0); Setlength(n.frac,0); End; Function ulFact(First:String):string; Var n1, n2:TNumber; I:integer; A, a1, a2:TMathArray; Max:integer; Begin. Str2Number('1', n1); Str2Number('1', n2); Num2Array(n1, a1); Num2Array(n2, a2); Max:=strtoint(First); For i:=1 to strtoint(First) do. Begin. If Assigned(OnProgress) then OnProgress((i/max)*100); Setlength(a,length(a1)+length(a2)+1); MultiplyArray(a1, a2, a); Setlength(a1,0); Setlength(a2,0); A1:=a; Str2Number(inttostr(i), n2); Num2Array(n2, a2); End; Array2Num(n1, a1, 0, true); Result:=Number2Str(n1); DisposeNumber(n1); End; Function ulPower(First, Second :string):string; Var i, j, c:integer; A, a1, a2:TMathArray; Var n1:TNumber; Max:integer; Begin. J:=strtoint(Second); If j=0 then. Begin. Result:='1'; Exit; End. Else. If j=1 then. Begin. Result:=First; Exit; End; Max:=j-1; Str2Number(First, n1); C:=Num2Array(n1, a1); Setlength(a,0); Setlength(a2,0); A2:=a1; For i:=1 to j-1 do. Begin. If Assigned(OnProgress) then OnProgress((i/max)*100); Setlength(a,0); Setlength(a,length(a1)+length(a2)+1); MultiplyArray(a1, a2, a); Setlength(a2,0); A2:=a; End; Setlength(a1,0); Setlength(a2,0); C:=c*j; If n1.sign then. Array2Num(n1, a, c, true). Else. If odd(j) then Array2Num(n1, a, c, false) else Array2Num(n1, a, c, true); Setlength(a,0); Result:=Number2Str(n1); DisposeNumber(n1); End; Procedure MultiplyNumbers(var n1, n2 :TNumber); Var i:integer; A, a1, a2:TMathArray; Begin. I:=Num2Array(n1, a1)+Num2Array(n2, a2); Setlength(a,length(a1)+length(a2)+1); MultiplyArray(a1, a2, a); Setlength(a1,0); Setlength(a2,0); Array2Num(n1, a, i, n1.sign=n2.sign); DisposeNumber(n2); Setlength(a,0); End; Function ulMPL(First, Second :string):string; Var n1, n2:TNumber; Begin. Str2Number(First, n1); Str2Number(Second, n2); MultiplyNumbers(n1, n2); Result:=Number2Str(n1); DisposeNumber(n1); End; Procedure AlignNumbers(var n1, n2:TNumber); Var i1, i2, i:integer; Begin. I1:=length(n1.int); I2:=length(n2.int); If i1>i2 then setlength(n2.int, i1); If i2>i1 then setlength(n1.int, i2); I1:=length(n1.frac); I2:=length(n2.frac); If i1>i2 then. Begin. Setlength(n2.frac, i1); For i:=i1-1 downto 0 do. Begin. If i-(i1-i2)>0 then n2.frac[i]:=n2.frac[i-(i1-i2)] else n2.frac[i]:=0; End; End; If i2>i1 then. Begin. Setlength(n1.frac, i2); For i:=i2-1 downto 0 do. Begin. If i-(i2-i1)>0 then n1.frac[i]:=n1.frac[i-(i2-i1)] else n1.frac[i]:=0; End; End; End; Function SubInteger(a1,a2:TMathArray):integer; Var i:integer; B:boolean; Begin. Result:=0; If length(a1)=0 then exit; For i:=0 to length(a1)-1 do a1[i]:=a1[i]-a2[i]; Repeat. B:=true; For i:=0 to length(a1)-1 do. If a1[i]<0 then. Begin. B:=false; If i=length(a1)-1 then. Begin. Result:=-1; A1[i]:=a1[i]+10; B:=true; End. Else. Begin. A1[i+1]:=a1[i+1]-1; A1[i]:=a1[i]+10; End; End; Until b; End; Procedure AssignNumber(out n1:TNumber; const n2:TNumber); Var i:integer; Begin. Setlength(n1.int, length(n2.int)); For i:=0 to length(n2.int)-1 do n1.int[i]:=n2.int[i]; Setlength(n1.frac, length(n2.frac)); For i:=0 to length(n2.frac)-1 do n1.frac[i]:=n2.frac[i]; N1.sign:=n2.sign; End; Procedure SubNumber(var n1, n2 : TNumber); Var i:integer; N:TNumber; Begin. AlignNumbers(n1, n2); I:=subInteger(n1.frac, n2.frac); N1.int[0]:=n1.int[0]+i; DisposeNumber(n); AssignNumber(n, n1); I:=subInteger(n1.int, n2.int); If i<0 then. Begin. SubInteger(n2.int, n.int); AssignNumber(n1, n2); End. Else. Begin. DisposeNumber(n2); End; End; Function SumInteger(a1,a2:TMathArray):integer; Var i:integer; B:boolean; Begin. Result:=0; If length(a1)=0 then exit; For i:=0 to length(a1)-1 do a1[i]:=a1[i]+a2[i]; Repeat. B:=true; For i:=0 to length(a1)-1 do. If a1[i]>9 then. Begin. B:=false; If i=length(a1)-1 then. Begin. Result:=1; A1[i]:=a1[i]-10; B:=true; End. Else. Begin. A1[i+1]:=a1[i+1]+1; A1[i]:=a1[i]-10; End; End; Until b; End; Procedure SumNumber(var n1, n2:TNumber); Var i:integer; Begin. AlignNumbers(n1, n2); I:=sumInteger(n1.frac, n2.frac); N1.int[0]:=n1.int[0]+i; I:=sumInteger(n1.int, n2.int); If i>0 then. Begin. Setlength(n1.int, length(n1.int)+1); N1.int[length(n1.int)-1]:=i; End; DisposeNumber(n2); End; Procedure SumNumbers(var n1, n2:TNumber); Begin. If n1.sign and n2.sign then. Begin. SumNumber(n1, n2); N1.sign:=true; End. Else. If (not n1.sign) and (not n2.sign) then. Begin. SumNumber(n1, n2); N1.sign:=False; End. Else. If (not n1.sign) and n2.sign then. Begin. SubNumber(n2, n1); AssignNumber(n1, n2); End. Else. Begin. SubNumber(n1, n2); End; End; Function ulSum(First, Second :string):string; Begin. Str2Number(First, n1); Str2Number(Second, n2); SumNumbers(n1, n2); Result:=Number2Str(n1); DisposeNumber(n1); End; Function ulSub(First, Second :string):string; Begin. Str2Number(First, n1); Str2Number(Second, n2); N2.sign:=not n2.sign; SumNumbers(n1, n2); Result:=Number2Str(n1); DisposeNumber(n1); End; Function DupChr(const X:Char;Count:Integer):AnsiString; Begin. If Count>0 then begin. SetLength(Result,Count); If Length(Result)=Count then FillChar(Result[1],Count,X); End; End; Function StrCmp(X,Y:AnsiString):Integer; Var. I,J:Integer; Begin. I:=Length(X); J:=Length(Y); If I=0 then begin. Result:=J; Exit; End; If J=0 then begin. Result:=I; Exit; End; If X[1]=#45 then begin. If Y[1]=#45 then begin. X:=Copy(X,2,I); Y:=Copy(Y,2,J); End else begin. Result:=-1; Exit; End; End else if Y[1]=#45 then begin. Result:=1; Exit; End; Result:=I-J; If Result=0 then Result:=CompareStr(X,Y); End; Function StrDiv(X,Y:AnsiString):AnsiString; Var. I,J:Integer; S,V:Boolean; T1,T2:AnsiString; R:string; Max:integer; Begin. Result:=#48; R:=#48; I:=Length(X); J:=Length(Y); S:=False; V:=False; If I=0 then Exit; If (J=0) OR (Y[1]=#48) then begin. Result:=''; R:=''; Exit; End; If X[1]=#45 then begin. Dec(I); V:=True; X:=Copy(X,2,I); If Y[1]=#45 then begin. Dec(J); Y:=Copy(Y,2,J). End else S:=True; End else if Y[1]=#45 then begin. Dec(J); Y:=Copy(Y,2,J); S:=True; End; Dec(I,J); If I<0 then begin. R:=X; Exit; End; T2:=DupChr(#48,I); T1:=Y+T2; T2:=#49+T2; Max:= Length(T1); While Length(T1)>=J do begin. While StrCmp(X,T1)>=0 do begin. X:=UlSub(X,T1); Result:=UlSum(Result,T2); End; SetLength(T1,Length(T1)-1); SetLength(T2,Length(T2)-1); If Assigned(OnProgress) then OnProgress(100-(Length(T1)/max)*100); End; R:=X; If S then if Result[1]<>#48 then Result:=#45+Result; If V then if R[1]<>#48 then R:=#45+R; End; Function Mul10(First:string; Second:integer):string; Var s:string; I, j:integer; Begin. If pos('.',First)=0 then. Begin. S:=''; For i:=0 to Second-1 do s:=s+'0'; Result:=First+s; End. Else. Begin. S:=''; J:=length(First)-pos('.',First); If (second-j)>0 then For i:=0 to Second-j-1 do s:=s+'0'; First:=First+s; J:=pos('.',First); First:=StringReplace(First,'.','',[]); Insert('.',First,j+second); While (length(First)>0) and (First[length(First)]='0') do delete(First,length(First),1); While (length(First)>0) and (First[length(First)]='.') do delete(First,length(First),1); Result:=First; End; End; Function Div10(First:string; Second:integer):string; Var s:string; I:integer; Begin. S:=''; For i:=0 to Second do s:=s+'0'; S:=s+First; Insert('.', s, length(s)-Second+1); While (length(s)>0) and (s[1]='0') do delete(s,1,1); If pos('.',s)>0 then. While (length(s)>0) and (s[length(s)]='0') do delete(s,length(s),1); If (length(s)>0) and (s[length(s)]='.') then delete(s,length(s),1); Result:=s; End; Function UlDiv(First, Second:String; Precision:integer):String; Begin. First:=Mul10(First, Precision); Result:=Div10(StrDiv(First, Second), Precision); End; End.

Простейший CGI на Дельфи.

Code: Program helloworld; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. {$E cgi}. Begin. Write('Content type: Text/HTML' + #13#10#13#10); Write('Hello World!'); End.

Как работать с комплексными числами?

Взято из http://www.ibrtses.com/delphi/complexrec.html.

Complex numbers.

Complex numbers have two representations :

Rectanglar : Z = a + i * b, a being the real part, and b being the imaginary part.

Polar : Z = r * exp(i * phi), r being the absolute value, and phi being the argument(angle).

A reason to demotivate compiler writers to have it as native type.

Here is a unit that approaches the complex as record.

The used record is of dual use, either rectangular or polar,

One just has to keep in mind what in is at the moment.

Code: { unit for complex numbers based on C_reords. ----------------------------------------- They are efficient on arrays. } Unit ComplexRec; Interface. Type. Float = extended; ComplexPtr = ^Complex; Complex = record // C_record without rectangular/polar discrimination. A, b: float; // (re,im) or (abs,arg). End; Function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a. Function C_One: ComplexPtr; // result:=1 BOTH. Function C_I: ComplexPtr; // result:=i RECTANGULAR. Function C_IP: ComplexPtr; // result:=i POLAR. Procedure C_P2R(a: ComplexPtr); // polar to rectangular. Procedure C_R2P(a: ComplexPtr); // rectangular to polar. Function C_abs(a: ComplexPtr): float; // RECTANGULAR. Function C_arg(a: ComplexPtr): float; // RECTANGULAR. Function C_re(a: ComplexPtr): float; // POLAR. Function C_im(a: ComplexPtr): float; // POLAR. Procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR. Procedure C_InvP(a: ComplexPtr); // a:=-a POLAR. Procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH. Function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH. Procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u; Procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u; Procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR. Function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR. Procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR. Function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR. Procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR. Function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR. Procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR. Function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR. Procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR. Function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR. Procedure C_Div(a, b: ComplexPtr); //a:=a/b POLAR. Function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR. Function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE. Function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR. Function C_SinN(a: ComplexPtr): ComplexPtr; Function C_CosN(a: ComplexPtr): ComplexPtr; Function C_TanN(a: ComplexPtr): ComplexPtr; Function C_SinhN(a: ComplexPtr): ComplexPtr; Function C_CoshN(a: ComplexPtr): ComplexPtr; Function C_TanhN(a: ComplexPtr): ComplexPtr; Function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr; // RECTANGLE. Function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr; // POLAR. Function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b =(a*b)/(a+b) RECTANGULAR. // electronic parallel circuit. Implementation. Uses math; Const AlmostZero = 1E-30; // test for zero. Function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a. Begin. Result := new(ComplexPtr); Result.a := a.a; result.b := a.b; End; Function C_One: ComplexPtr; // result:=1. Begin. Result := new(ComplexPtr); Result.a := 1; result.b := 0; End; Function C_I: ComplexPtr; // result:=i RECTANGULAR. Begin. Result := new(ComplexPtr); Result.a := 0; result.b := 1; End; Function C_IP: ComplexPtr; // result:=i POLAR. Begin. Result := new(ComplexPtr); Result.a := 1; result.b := pi / 2; End; Procedure C_P2R(a: ComplexPtr); Var t, u, v: float; Begin. T := a.a; Sincos(a.b, u, v); A.a := t * v; a.b := t * u; End; Procedure C_R2P(a: ComplexPtr); Var t: float; Begin. T := a.a; a.a := sqrt(sqr(a.a) + sqr(a.b)); If (abs(t)0 then a.b := pi / 2. Else. A.b := -pi / 2; End. Else. Begin. A.b := arctan(a.b / t); If (t < 0) then a.b := a.b + pi; End; End; Function C_abs(a: ComplexPtr): float; Begin. Result := sqrt(sqr(a.a) + sqr(a.b)); End; Function C_arg(a: ComplexPtr): float; Begin. If (abs(a.a)0 then result := pi / 2. Else. Result := -pi / 2; End. Else. Begin. Result := arctan(a.b / a.a); If (a.a < 0) then result := result + pi; End; End; Function C_re(a: ComplexPtr): float; // POLAR. Begin. Result := a.a * cos(a.b); End; Function C_im(a: ComplexPtr): float; // POLAR. Begin. Result := a.a * sin(a.b); End; Procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR. Begin. A.a := -a.a; a.b := -a.b; End; Procedure C_InvP(a: ComplexPtr); // a:=-a POLAR. Begin. A.b := a.b + pi; End; Procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH. Begin. A.b := -a.b; End; Function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH. Begin. Result := new(ComplexPtr); Result.a := a.a; Result.b := -a.b; End; Procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u; Begin. A.a := a.a * u; A.b := a.b * u; End; Procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u; Begin. A.a := a.a * u; End; Procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR. Begin. A.a := a.a + b.a; A.b := a.b + b.b; End; Function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR. Begin. Result := new(ComplexPtr); Result.a := a.a + b.a; Result.b := a.b + b.b; End; Procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR. Begin. A.a := a.a - b.a; A.b := a.b - b.b; End; Function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR. Begin. Result := new(ComplexPtr); Result.a := a.a - b.a; Result.b := a.b - b.b; End; Procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR. Var u, v: float; Begin. U := a.a * b.a - a.b * b.b; V := a.a * b.b + a.b * b.a; A.a := u; A.b := v; End; Function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR. Begin. Result := new(ComplexPtr); Result.a := a.a * b.a - a.b * b.b; Result.b := a.a * b.b + a.b * b.a; End; Procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR. Begin. A.a := a.a * b.a; A.b := a.b + b.b; End; Function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR. Begin. Result := new(ComplexPtr); Result.a := a.a * b.a; Result.b := a.b + b.b; End; Procedure C_Div(a, b: ComplexPtr); //a:=a/b RECTANGULAR. Var t: float; Begin. T := a.a / b.a + a.b / b.b; A.b := -a.a / b.b + a.b / b.a; A.a := t; End; Function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b RECTANGULAR. Begin. Result := new(ComplexPtr); Result.a := a.a / b.a + a.b / b.b; Result.b := -a.a / b.b + a.b / b.a; End; Procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR. Begin. A.a := a.a / b.a; A.b := a.b - b.b; End; Function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR. Begin. Result := new(ComplexPtr); Result.a := a.a / b.a; Result.b := a.b - b.b; End; Function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE. Begin. Result := new(ComplexPtr); Result.a := exp(a.a); Result.b := a.b; C_P2R(result); End; Function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR. Begin. Result := new(ComplexPtr); Result.a := ln(a.a); Result.b := a.b; C_R2P(result); End; Function C_SinN(a: ComplexPtr): ComplexPtr; Var z, n, v, t: ComplexPtr; Begin. T := C_I; V := C_MulN(a, t); // i*a. Z := C_expN(a); // exp(i*a). T := C_Copy(v); C_Inv(t); // -i*a. T := C_ExpN(v); // exp(-i*a). C_Sub(z, t); N := C_I; C_Scale(n, 2); Result := C_DivN(z, n); Dispose(z); dispose(n); dispose(v); dispose(t); End; Function C_CosN(a: ComplexPtr): ComplexPtr; Var z, n, v, t: ComplexPtr; Begin. T := C_I; V := C_MulN(a, t); // i*a. Z := C_expN(a); // exp(i*a). T := C_Copy(v); C_Inv(t); // -i*a. T := C_ExpN(v); // exp(-i*a). C_Add(z, t); N := C_One; C_Scale(n, 2); Result := C_DivN(z, n); Dispose(z); dispose(n); dispose(v); dispose(t); End; Function C_TanN(a: ComplexPtr): ComplexPtr; Begin. End; Function C_SinhN(a: ComplexPtr): ComplexPtr; Var u, v, t: ComplexPtr; Begin. U := C_ExpN(a); T := C_Copy(a); C_inv(t); V := C_ExpN(t); Result := C_SubN(u, v); C_Scale(result, 1 / 2); Dispose(u); Dispose(v); Dispose(t); End; Function C_CoshN(a: ComplexPtr): ComplexPtr; Var u, v, t: ComplexPtr; Begin. U := C_ExpN(a); T := C_Copy(a); C_inv(t); V := C_ExpN(t); Result := C_AddN(u, v); C_Scale(result, 1 / 2); Dispose(u); Dispose(v); Dispose(t); End; Function C_TanhN(a: ComplexPtr): ComplexPtr; Begin. End; Function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr; Var j: integer; U, v: float; Begin. If n = 0 then. Result := C_One. Else. Begin. Result := C_Copy(a); If n > 1 then. Begin. C_R2P(result); U := result.a; v := result.b; For j := 2 to n do. Begin. U := u * result.a; v := v + result.b; End; Result.a := u; result.b := v; C_P2R(result); End; If n < 0 then. Begin. End; End; End; Function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr; Var j: integer; U, v: float; Begin. Result := C_Copy(a); U := result.a; v := result.b; For j := 2 to n do. Begin. U := u * result.a; v := v + result.b; End; Result.a := u; result.b := v; End; Function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b = (a*b)/(a+b). Var z, n: ComplexPtr; Begin. Z := C_MulN(a, b); N := C_AddN(a, b); C_R2P(n); C_R2P(z); Result := C_DivNP(z, n); C_P2R(result); Dispose(n); Dispose(z); End; End.

Как нарисовать кривую Безье?

Как нарисовать кривую.

Безье. Именно она применяется для построения гладких кривых во всех графических.

Программах - от PaintBrush до CorelDraw и PhotoShop. Для задания кривой Безье n-ной степени (чем больше степень, тем более кривой.

Может быть линия; кривая первой степени - отрезок) нужно указать n+1 точку. Первая.

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

На других участках. В частности, первая и n-ая точки задают касательные и кривизну.

Кривой на ее концах. В большинстве программ используются кривые Безье третьего.

Порядка. Начиная с Delphi5 такую кривую можно нарисовать при помощи функции PolyBezier. Кривая Безье задается параметрически (x=x(t), y=y(t)). Это позволяет ей вести.

Себя абсолютно произвольно. Если бы она задавалась, как y(x), она не смогла бы.

Даже сделать поворот на 180 градусов. Функции x(t) и y(t) выглядят так:

X(t)= Cn0 * t0 * (1-t)n * x0 + Cn1 * t1 * (1-t)n-1 * x1 + Cn2 * t2 * (1-t)n-2.

* x2 + ... + Cnn * tn * (1-t)0 * xn.

Y(t)= Cn0 * t0 * (1-t)n * y0 + Cn1 * t1 * (1-t)n-1 * y1 + Cn2 * t2 * (1-t)n-2.

* y2 + ... + Cnn * tn * (1-t)0 * yn.

Где n - порядок кривой, Cni - коэффициенты в разложении бинома Ньютона, t - параметр,

Меняющийся от 0 до 1, xi, yi - координаты опорных точек. Эта программа строит кривую Безье n-ного порядка. n задается в SpinEdit1. Все.

Узлы можно перемещать по полю мышью. Для создания нового узла нужно нажать мышью.

На пустое место на поле или увеличить порядок кривой. Скачать необходимые для компиляции файлы проекта можно на http://program.dax.ru/.

Code: Uses Math; Const. RectSize = 5; MaxN = 128; Var. N: integer = -1; Pt: array [0..MaxN] of TPoint; C: array [0..MaxN] of single; Bm: TBitMap; Function GetBinomialCoefficient(m, i: integer): single; Function Factorial(x: integer): double; Var i: integer; Begin. Result := 1; For i := 2 to x do result := result * i; End; Begin. Result := Factorial(m) / (Factorial(i) * Factorial(m - i)); End; Procedure DrawBezier(Canvas: TCanvas; Count: integer); Type. TPointArray = array [word] of TPoint; PPointArray = ^TPointArray; Var. P: PPointArray; Step, qx, qy, t, q: single; I, j: integer; Begin. GetMem(p, sizeof(TPoint) * (Count + 1)); Step := 1.0 / Count; For i := 0 to Count do. Begin. T := i * Step; Qx := 0; qy := 0; For j := 0 to n do. Begin. Q := C[j] * IntPower(1 - t, j) * IntPower(t, n - j); Qx := qx + q * pt[j].x; Qy := qy + q * pt[j].y; End; P[i] := Point(round(qx), round(qy)); End; Canvas.Polyline(Slice(p^, Count + 1)); FreeMem(p); End; Procedure DrawLines(canvas: TCanvas; const pt: array of TPoint); Var. I: integer; Begin. Canvas.Pen.Color := clGreen; Canvas.Pen.Width := 1; Canvas.MoveTo(pt[0].x, pt[0].y); For i := 0 to n do. Begin. Canvas.Rectangle(Bounds(pt[i].x - RectSize, pt[i].y - RectSize, 2 * RectSize, 2 * RectSize)); Canvas.LineTo(pt[i].x, pt[i].y); End; End; Procedure Redraw; Begin. With Form1.PaintBox1 do. Begin. Bm.Canvas.FillRect(Bounds(0, 0, Width, Height)); If Form1.CheckBox1.Checked then DrawLines(bm.Canvas, pt); Bm.Canvas.PolyBezier(pt); Bm.Canvas.Pen.Color := clRed; Bm.Canvas.pen.Width := Form1.SpinEdit3.Value; DrawBezier(bm.Canvas, Form1.SpinEdit2.Value); Canvas.Draw(0, 0, bm); End; End; Var. Moving: integer = -1; Oldr: TRect; Procedure FillRandom(NewN: integer); Var. I: integer; Begin. Randomize; For i := n+1 to NewN do pt[i] := Point(random(Form1.PaintBox1.Width - 20) + 10, Random(Form1.PaintBox1.Height - 20) + 10); N := NewN; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Bm := TBitmap.Create; Bm.Width := PaintBox1.Width; Bm.Height := PaintBox1.height; SpinEdit1.MinValue := 1; SpinEdit1.MaxValue := MaxN; SpinEdit1.Value := 3; SpinEdit2.MinValue := 6; SpinEdit2.MaxValue := MaxN * 4; SpinEdit2.Value := 50; SpinEdit2.OnChange := PaintBox1.OnPaint; SpinEdit3.MinValue := 1; SpinEdit3.MaxValue := 8; SpinEdit3.Value := 3; SpinEdit3.OnChange := PaintBox1.OnPaint; CheckBox1.Checked := true; CheckBox1.OnClick := PaintBox1.OnPaint; End; Procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. I: integer; R: TRect; Begin. If Button <> mbLeft then Exit; For i := 0 to n do. If (abs(X - pt[i].x) <= RectSize) and (abs(Y - pt[i].y) <= RectSize) then. Begin. Moving := i; R.TopLeft := Form1.ClientToScreen(PaintBox1.BoundsRect.TopLeft); R.BottomRight := Form1.ClientToScreen(PaintBox1.BoundsRect.BottomRight); GetClipCursor(oldr); ClipCursor(@r); Exit; End; If moving < 0 then. Begin. SpinEdit1.Value := SpinEdit1.Value + 1; Pt[n] := Point(X, Y); Redraw; End; End; Procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If moving < 0 then Exit; Pt[moving] := Point(X, Y); Redraw; End; Procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If (Button = mbLeft) and (moving >= 0) then. Begin. Moving := -1; ClipCursor(@oldr); End; End; Procedure TForm1.SpinEdit1Change(Sender: TObject); Var. I: integer; Begin. FillRandom(SpinEdit1.Value); SpinEdit2.MinValue := n * 2; For i := 0 to n do C[i] := GetBinomialCoefficient(n, i); Redraw; End; Procedure TForm1.PaintBox1Paint(Sender: TObject); Begin. Redraw; End;

Как нарисовать график функции?

Code: Procedure TForm1.Button3Click(Sender: TObject); Var x, y: array[1..50] of double; I: integer; Scalex, scaley, ymin, ymax, xmin, xmax: double; Begin. For i := 1 to 50 do. Begin. Y[i] := sin(i * 0.5); X[i] := i; End; Xmin := x[1]; Xmax := x[1]; Ymin := y[1]; Ymax := y[1]; For i := 2 to 50 do. Begin // или используйте ymin:=MinValue(y); и т.д. If y[i] < ymin then ymin := y[i]; If y[i] > ymax then ymax := y[i]; If x[i] < xmin then xmin := x[i]; If x[i] > xmax then xmax := x[i]; End; Scalex := paintbox1.Width / (xmax - xmin); Scaley := paintbox1.Height / (ymax - ymin); With paintbox1.canvas do. Begin. Moveto(trunc(scalex * (x[1] - xmin)), paintbox1.height - trunc(scaley * (y[1] - ymin))); For i := 2 to 50 do. Lineto(trunc(scalex * (x[i] - xmin)), paintbox1.height - trunc(scaley * (y[i] - ymin))); End; End;

©Drkb::04098.

Забавная штука синусы:

Code: For i:=1 to 500 do begin. Paintbox1.Canvas.Pixels [round(sin(i*5)*10+50),round(sin(i*10)*10+50)] := RGB(0,0,0);

Пример шифрования данных.

Code: Procedure DoEncode(var Source:String; const Key:string); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Asm. Push ESI. Push EDI. Push EBX. Or EAX,EAX. Jz @Done. Push EAX. Push EDX. Call UniqueString. Pop EDX. Pop EAX. Mov EDI,[EAX]. Or EDI,EDI. Jz @Done. Mov ECX,[EDI-4]. Jecxz @Done. Mov ESI,EDX. Or ESI,ESI. Jz @Done. Mov EDX,[ESI-4]. Dec EDX. Js @Done. Mov EBX,EDX. Mov AH,DL. Cld. @L1: Test AH,8. Jnz @L3. Xor AH,1. @L3: Not AH. Ror AH,1. Mov AL,[ESI+EBX]. Xor AL,AH. Xor AL,[EDI]. Stosb. Dec EBX. Jns @L2. Mov EBX,EDX. @L2: Dec ECX. Jnz @L1. @Done: Pop EBX. Pop EDI. Pop ESI. End;

CRC32.

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Function CRC32(const IniCRC:Integer;Source:AnsiString):Integer; Asm. Push EBX. Push ESI. Push EDI. Or EDX,EDX. Jz @Done. Mov ESI,EDX. Mov ECX,[EDX-4]. Jecxz @Done. Lea EDI,@CRCTbl. Mov EDX,EAX. Xor EAX,EAX. Cld. @L1: Lodsb. Mov EBX,EDX. Xor EBX,EAX. And EBX,$FF. Shl EBX,2. Shr EDX,8. And EDX,$FFFFFF. Xor EDX,[EDI+EBX]. Dec ECX. Jnz @L1. Mov EAX,EDX. @Done: Pop EDI. Pop ESI. Pop EBX. Ret. @CRCTbl: DD $00000000, $77073096, $ee0e612c, $990951ba. DD $076dc419, $706af48f, $e963a535, $9e6495a3. DD $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988. DD $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91. DD $1db71064, $6ab020f2, $f3b97148, $84be41de. DD $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7. DD $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec. DD $14015c4f, $63066cd9, $fa0f3d63, $8d080df5. DD $3b6e20c8, $4c69105e, $d56041e4, $a2677172. DD $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b. DD $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940. DD $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59. DD $26d930ac, $51de003a, $c8d75180, $bfd06116. DD $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f. DD $2802b89e, $5f058808, $c60cd9b2, $b10be924. DD $2f6f7c87, $58684c11, $c1611dab, $b6662d3d. DD $76dc4190, $01db7106, $98d220bc, $efd5102a. DD $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433. DD $7807c9a2, $0f00f934, $9609a88e, $e10e9818. DD $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01. DD $6b6b51f4, $1c6c6162, $856530d8, $f262004e. DD $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457. DD $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c. DD $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65. DD $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2. DD $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb. DD $4369e96a, $346ed9fc, $ad678846, $da60b8d0. DD $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9. DD $5005713c, $270241aa, $be0b1010, $c90c2086. DD $5768b525, $206f85b3, $b966d409, $ce61e49f. DD $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4. DD $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad. DD $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a. DD $ead54739, $9dd277af, $04db2615, $73dc1683. DD $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8. DD $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1. DD $f00f9344, $8708a3d2, $1e01f268, $6906c2fe. DD $f762575d, $806567cb, $196c3671, $6e6b06e7. DD $fed41b76, $89d32be0, $10da7a5a, $67dd4acc. DD $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5. DD $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252. DD $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b. DD $d80d2bda, $af0a1b4c, $36034af6, $41047a60. DD $df60efc3, $a867df55, $316e8eef, $4669be79. DD $cb61b38c, $bc66831a, $256fd2a0, $5268e236. DD $cc0c7795, $bb0b4703, $220216b9, $5505262f. DD $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04. DD $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d. DD $9b64c2b0, $ec63f226, $756aa39c, $026d930a. DD $9c0906a9, $eb0e363f, $72076785, $05005713. DD $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38. DD $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21. DD $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e. DD $81be16cd, $f6b9265b, $6fb077e1, $18b74777. DD $88085ae6, $ff0f6a70, $66063bca, $11010b5c. DD $8f659eff, $f862ae69, $616bffd3, $166ccf45. DD $a00ae278, $d70dd2ee, $4e048354, $3903b3c2. DD $a7672661, $d06016f7, $4969474d, $3e6e77db. DD $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0. DD $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9. DD $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6. DD $bad03605, $cdd70693, $54de5729, $23d967bf. DD $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94. DD $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d. End;

Как вычислить математическое выражение.

Зачастую пользователь должен ввести что-то типа "1+2/(3*4)" и программа должна разобрать выражение и произвести вычисления. Делается это с помощью рекурсивных функций, которые постеменно разбирают выражение. К счастью не обязательно изобретать велосипед: в бесплатной библиотеке RxLib есть модуль Parsing.pas включающий в себя класс для вычисления математических выражений, библиотеку можно взять на.

Http://www.rxlib.ru/Downl/Downl.htm.

Или.

Http://www.torry.net.

Модуль Parsing.pas вполне может работать отдельно и без установки пакета компонент (но в таком случае вам прийдется взять еще несколько inc файлов помимо него).

©Drkb::04227.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

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

Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются" символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно, всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до сложения с вычитанием.

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

Вот модуль с этими методами.

Code: Unit Recognition; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math; Type. TVar = set of char; Procedure Preparation(var s: String; variables: TVar); Function ChangeVar(s: String; c: char; value: extended): String; Function Recogn(st: String; var Num: extended): boolean; Implementation. Procedure Preparation(var s: String; variables: TVar); Const. Operators: set of char = ['+','-','*', '/', '^']; Var. I: integer; Figures: set of char; Begin. Figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables; // " ". Repeat. I := pos(' ', s); If i <= 0 then break; Delete(s, i, 1); Until 1 = 0; S := LowerCase(s); // ".", ",". If DecimalSeparator = '.' then begin. I := pos(',', s); While i > 0 do begin. S[i] := '.'; I := pos(',', s); End; End else begin. I := pos('.', s); While i > 0 do begin. S[i] := ','; I := pos('.', s); End; End; // Pi. Repeat. I := pos('pi', s); If i <= 0 then break; Delete(s, i, 2); Insert(FloatToStr(Pi), s, i); Until 1 = 0; // ":". Repeat. I := pos(':', s); If i <= 0 then break; S[i] := '/'; Until 1 = 0; // |...| Repeat. I := pos('|', s); If i <= 0 then break; S[i] := 'a'; Insert('bs(', s, i + 1); I := i + 3; Repeat i := i + 1 until (i > Length(s)) or (s[i] = '|'); If s[i] = '|' then s[i] := ')'; Until 1 = 0; // #...# I := 1; Repeat. If s[i] in figures then begin. Insert('#', s, i); I := i + 2; While (s[i] in figures) do i := i + 1; Insert('#', s, i); I := i + 1; End; I := i + 1; Until i > Length(s); End; Function ChangeVar(s: String; c: char; value: extended): String; Var. P: integer; Begin. Result := s; Repeat. P := pos(c, result); If p <= 0 then break; Delete(result, p, 1); Insert(FloatToStr(value), result, p); Until 1 = 0; End; Function Recogn(st: String; var Num: extended): boolean; Const. Pogr = 1E-5; Var. P, p1: integer; I, j: integer; V1, v2: extended; Func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp); Sign: integer; S: String; S1: String; Function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean; Var. I: integer; Begin. I := p - 1; Repeat i := i - 1 until (i <= 0) or (s[i] = '#'); Margin := i; Try. Value := StrToFloat(copy(s, i + 1, p - i - 2)); Result := true; Except. Result := false. End; Delete(s, i, p - i); End; Function FindRightValue(p: integer; var Value: extended): boolean; Var. I: integer; Begin. I := p + 1; Repeat i := i + 1 until (i > Length(s)) or (s[i] = '#'); I := i - 1; S1 := copy(s, p + 2, i - p - 1); Result := TextToFloat(PChar(s1), value, fvExtended); Delete(s, p + 1, i - p + 1); End; Procedure PutValue(p: integer; NewValue: extended); Begin. Insert('#' + FloatToStr(v1) + '#', s, p); End; Begin. Result := false; S := st; // (). P := pos('(', s); While p > 0 do begin. I := p; J := 1; Repeat. I := i + 1; If s[i] = '(' then j := j + 1; If s[i] = ')' then j := j - 1; Until (i > Length(s)) or (j <= 0); If i > Length(s) then s := s + ')'; If Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit; Delete(s, p, i - p + 1); PutValue(p, v1); P := pos('(', s); End; // sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp. Repeat. Func := fNone; P1 := pos('sin', s); If p1 > 0 then begin. Func := fSin; P := p1; End; P1 := pos('cos', s); If p1 > 0 then begin. Func := fCos; P := p1; End; P1 := pos('tg', s); If p1 > 0 then begin. Func := fTg; P := p1; End; P1 := pos('ctg', s); If p1 > 0 then begin. Func := fCtg; P := p1; End; P1 := pos('arcsin', s); If p1 > 0 then begin. Func := fArcsin; P := p1; End; P1 := pos('arccos', s); If p1 > 0 then begin. Func := fArccos; P := p1; End; P1 := pos('arctg', s); If p1 > 0 then begin. Func := fArctg; P := p1; End; P1 := pos('arcctg', s); If p1 > 0 then begin. Func := fArcctg; P := p1; End; P1 := pos('abs', s); If p1 > 0 then begin. Func := fAbs; P := p1; End; P1 := pos('ln', s); If p1 > 0 then begin. Func := fLn; P := p1; End; P1 := pos('lg', s); If p1 > 0 then begin. Func := fLg; P := p1; End; P1 := pos('exp', s); If p1 > 0 then begin. Func := fExp; P := p1; End; If func = fNone then break; Case func of. FSin, fCos, fCtg, fAbs, fExp: i := p + 2; FArctg: i := p + 4; FArcsin, fArccos, fArcctg: i := p + 5; Else i := p + 1; End; If FindRightValue(i, v1) = false then Exit; Delete(s, p, i - p + 1); Case func of. FSin: v1 := sin(v1); FCos: v1 := cos(v1); FTg: begin. If abs(cos(v1)) < pogr then Exit; V1 := sin(v1) / cos(v1); End; FCtg: begin. If abs(sin(v1)) < pogr then Exit; V1 := cos(v1) / sin(v1); End; FArcsin: begin. If Abs(v1) > 1 then Exit; V1 := arcsin(v1); End; FArccos: begin. If abs(v1) > 1 then Exit; V1 := arccos(v1); End; FArctg: v1 := arctan(v1); // fArcctg: v1 := arcctan(v1); FAbs: v1 := abs(v1); FLn: begin. If v1 < pogr then Exit; V1 := Ln(v1); End; FLg: begin. If v1 < 0 then Exit; V1 := Log10(v1); End; FExp: v1 := exp(v1); End; PutValue(p, v1); Until func = fNone; // power. P := pos('^', s); While p > 0 do begin. If FindRightValue(p, v2) = false then Exit; If FindLeftValue(p, i, v1) = false then Exit; If (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit; If (abs(v1) < pogr) and (v2 < 0) then Exit; Delete(s, i, 1); V1 := Power(v1, v2); PutValue(i, v1); P := pos('^', s); End; // *, / P := pos('*', s); P1 := pos('/', s); If (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1; While p > 0 do begin. If FindRightValue(p, v2) = false then Exit; If FindLeftValue(p, i, v1) = false then Exit; If s[i] = '*' Then v1 := v1 * v2. Else begin. If abs(v2) < pogr then Exit; V1 := v1 / v2; End; Delete(s, i, 1); PutValue(i, v1); P := pos('*', s); P1 := pos('/', s); If (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1; End; // +, - Num := 0; Repeat. Sign := 1; While (Length(s) > 0) and (s[1] <> '#') do begin. If s[1] = '-' then Sign := -Sign. Else if s[1] <> '+' then Exit; Delete(s, 1, 1); End; If FindRightValue(0, v1) = false then Exit; If Sign < 0. Then Num := Num - v1. Else Num := Num + v1; Until Length(s) <= 0; Result := true; End; End.

Общие сведения о COM (статья).

Эта статья целиком и полностью написана Fаntаsist'ом, за что ему огромное спасибо.

Хотел я в общих словах расказать основную идею СОМ. Когда я понял, что это такое показалась такая простая вещь, что можно коротко рассказать. Но не получилось...

Что ж, будет немного подлиннее.

©Drkb::04312.

Автор: Fantasist.

Взято с Vingrad.ru http://forum.vingrad.ru.

Простой пример.

Итак, попробуем рассказать в простоте. Вот есть у вас класс - примитивный калькулятор:

Code: MyCalc=class. Fx,fy:integer; Public: Procedure SetOperands(x,y:integer). Function Sum:integer; Function Diff:integer; End; Procedure MyCalc.SetOperands(x,y:integer). Begin. Fx:=x; fy:=y; End; Function MyCalc.Sum:integer; Begin. Result:=fx+fy; End; Function MyCalc.Diff:integer; Begin. Result:=fx-fy; End;

DLL!

Ура. До нас и за нас все уже стандатизировали. Давайте этим воспользуемся и напишим теперь наш модуль в постандарту. Напишим dll.

Code: Library CalcDll; Uses SysUtils, Classes; Type. MyCalc=class. Fx,fy:integer; Public. Procedure SetOperands(x,y:integer); Function Sum:integer; Function Diff:integer; End; Var Calc:MyCalc; Procedure MyCalc.SetOperands(x,y:integer); Begin. Fx:=x; fy:=y; End; Function MyCalc.Sum:integer; Begin. Result:=fx+fy; End; Function MyCalc.Diff:integer; Begin. Result:=fx-fy; End; Procedure SetOperands(x,y:integer); Begin. Calc.SetOperands(x,y); End; Function Sum:integer; Begin. Result:=Calc.Sum; End; Function Diff:integer; Begin. Result:=Calc.Diff; End; Procedure CreateObject; Begin. Calc:=MyCalc.Create; End; Procedure ReleaseObject; Begin. Calc.Free; End; Exports //Вот эта секция и указывает компилятору что записать в таблицу экспорта. SetOperands, Sum, Diff, CreateObject, ReleaseObject; Begin. End.

Как взять URL из окна IE?

Code: Uses windows, ddeman, ...... Function Get_URL(Servicio: string): String; Uses windows, ddeman, ...... Function Get_URL(Servicio: string): String; Var. Cliente_DDE: TDDEClientConv; Temp:PChar; Begin. Result := ''; Cliente_DDE:= TDDEClientConv.Create( nil ); With Cliente_DDE do. Begin. SetLink( Servicio,'WWW_GetWindowInfo'); Temp := RequestData('0xFFFFFFFF'); Result := StrPas(temp); StrDispose(temp); //<<-Предотвращаем утечку памяти. CloseLink; End; Cliente_DDE.Free; End; Procedure TForm1.Button1Click(Sender); Begin. Showmessage(Get_URL('Netscape')); Или. Showmessage(Get_URL('IExplore')); End;

Еще шаг в направлении COM.

Сделаем еще шаг в направлении Component Object Module (COM).Даже сейчас у экспортируется довольно много функций. Соответсвенно и в программе нам надо сделать несколько ступений - создать переменную-указатель, присвоить ей значение адреса нужной функции при помощи GetProcAddress, и только потом вызвать саму функцию. Причем все эти функции у нас сами по себе и никак не связанны с самим объектом, который мы используем. А неплохо бы сделать так, чтобы можно было работать с ними как с объектом, что нибудь типа:

Са1с.SetOperands(13,10);

I:=Calc.Sum;

Так давайте так и сделаем! Правда мы ограничены экспортом только функций, но мы сделаем так:

Добавим в dll такую запись.

Code: Type. ICalc=record. SetOpers:procedure (x,y:integer); Sum:function:integer; Diff:function:integer; Release:procedure; End;

Понятие интерфейса.

Тут наконец проявляется одно из ключевых понятий COM - интерфейс(interface).

Наша запись ICalc - это он и есть. То есть интерфейс - это таблица содержашаяя указатели на функции. Когда вы работаете с COM объектом, несмотря на то, что это выглядит так, как будто вы работаете с самим объектом, вы работаете с его интерфейсами. Реализация здесь может быть разная, это может быть указатели на внешнии функции, как это сделанно у нас (так практическм никто не делает), но чаще всего это указатели на методы класса. Пользователя это не волнует - он получает интерфейс и с ним работает, а уж ваша задача потрудиться над тем, чтобы работа с вашим интерфейсом проходила корректно.

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

Code: Procedure MyCalc.Mult; //умножение. Begin. Result:=fx*fy; End; Procedure MyCalc.Divide; //деление. Begin. Result:=fx div fy; End;

Понятие интерфейсе - 2.

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

Code: ICalc2=interface(ICalc). Function Mult:integer; Function Divide:integer; End;

Собираем тестовый пример.

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

В начале код dll c объектом.

Code: Library CalcDll; Uses. SysUtils, Classes; Type. HResult=Longint; ICalcBase=interface //чисто абстрактный интерфейс. Procedure SetOperands(x,y:integer); Procedure Release; End; ICalc=interface(ICalcBase). ['{149D0FC0-43FE-11D6-A1F0-444553540000}']. Function Sum:integer; Function Diff:integer; End; ICalc2=interface(ICalcBase). ['{D79C6DC0-44B9-11D6-A1F0-444553540000}']. Function Mult:integer; Function Divide:integer; End; MyCalc=class(TObject,ICalc,ICalc2) //два интерфейса. Fx,fy:integer; Public. Procedure SetOperands(x,y:integer); Function Sum:integer; Function Diff:integer; Function Divide:integer; Function Mult:integer; Procedure Release; Function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; Function _AddRef:Longint; stdcall; Function _Release:Longint; stdcall; End; Const. S_OK = 0; E_NOINTERFACE = HRESULT($80004002); Procedure MyCalc.SetOperands(x,y:integer); Begin. Fx:=x; fy:=y; End; Function MyCalc.Sum:integer; Begin. Result:=fx+fy; End; Function MyCalc.Diff:integer; Begin. Result:=fx-fy; End; Function MyCalc.Divide:integer; Begin. Result:=fx div fy; End; Function MyCalc.Mult:integer; Begin. Result:=fx*fy; End; Procedure MyCalc.Release; Begin. Free; End; Function MyCalc.QueryInterface(const IID: TGUID; out Obj): HResult; Begin. If GetInterface(IID, Obj) then. Result := S_OK. Else. Result := E_NOINTERFACE; End; Function MyCalc._AddRef; Begin. End; Function MyCalc._Release; Begin. End; Procedure CreateObject(const IID: TGUID; var ACalc); Var. Calc:MyCalc; Begin. Calc:=MyCalc.Create; If not Calc.GetInterface(IID,ACalc) then. Calc.Free; End; Exports. CreateObject; Begin. End.

Стандарт СОМ.

Продолжаем, осталось совсем немного, чтобы подогнать под стандарт COM.

Какой у нас пробел еще остался? Представте, что кто-то сделал так:

Code: Var. Calc:ICalc; Calc2:ICalc2; Begin. CreateObject(ICalc,Calc); Calc.QueryInterafce(ICalc2,Calc2). ... Calc.Release; //объект уничтожается. I:=Calc2.Mult; //Облом! Объекта уже нет. ... End;

Как система создаёт объект СОМ.

Итак, давайте посмотрим как система создает СОМ объект. (Все, что написанно далее про создание СОМ объекта, не является стандартом СОМ, а является поддержкой работы COM системой. То есть так поддержка реализованна в Windows. В других системах поддержка COM (если вы ее там найдете) может быть реализована по другому.) Наиболее часто используемая API функция в Windows для создания СОМ объекта это CoCreateInstance (все названия функций Win API для работы с СОМ имеют префикс Со). Выглядит она так:

Code: STDAPI CoCreateInstance( REFCLSID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFIID riid, LPVOID * ppv. );

IClassFactory.

Итак, IClassFactory предназначен для того, чтобы создавать экземпляры соответствующего класса. То есть строчкой:

Code: CoGetClassObject(Calc_CLSID, dwClsContext, nil, IClassFactory,p); //Calc_CLSID - GUID нашего калькулятора.

Работа с Excel из Дельфи.

Чтобы работать с Excel из Delphi существует два основных пути. Первый - это создание его как COM объект. Таким же образом можно работать и с Word, Access, Outlook(не Express) и многими другими программами.

Второй способ (для таблицы Excel) это подключение черезАDО, DAO(Data Active Objects) или ODBC.

Есть замечательный цикл книг по этой теме.

Vit.

©Drkb::04367.

Взято с Vingrad.ru http://forum.vingrad.ru.

Через СОМ интерфейс.

Code: Var Excel, WorkBook, Sheet: Variant; Begin. Excel := CreateOleObject('Excel.Application'); Excel.WorkBooks.Open(FileName,False); WorkBook := Excel.WorkBooks.Item[1]; Sheet := Workbook.Sheets.Item[3]; Sheet.Cells[1,2]:='ASDFG'; Sheet.Cells[2,2]:=230;

Через DAO/ODBC/ADO.

Чтобы использовать только стандартные компоненты давайте попробуем работать с Excel через ADO. Это не самый быстрый и далеко не первый по возможностям метод (DAO работает на порядок быстрее и предоставляет куда больше возможностей), но ADO компоненты входят в стандартную поставку 5 и 6 Дельфи. Итак заходим в Панель управления Windows, идем в свойства ODBC, делаем DSN используя Excel драйвер, не забываем указать в свойствах на файл Excel. Закрываем ODBC, открываем Дельфи. Ставим на форму ADOConnection. Идем в ConnectionString - строим строку подключения - надо выбрать только ODBC провайдер и на следующей вкладке указать сделанный DSN, остальные опции в большинстве случаев можно оставить как есть. Строка получена. Кстати ее можно вообще упростить до вида: "DSN=MyDsn". Теперь вам доступны листы файла как таблицы а весь файл как база данных. Подключаем ADOQuery к ADOConnection. Создаем таблицу, т.е. новый лист - путем запуска следующей квери:

Code: Create Table MyTable1 ( Field1 varchar(20), Field2 varchar(10) ).

Подключен ли в своем компе протокол TCP/IP?

Думаю что надёжнее всего "ping 127.0.0.1" потому что другие методы не дадут уверенности что протокол работает нормально.

Почему именно ping 127.0.0.1?

127.0.0.1 - или по другому localhost - это предопределённый протоколом TCP/IP собственный (внутренний) адрес компьютера, так что если TCP/IP установлен и работает, то этот адрес точно есть и должен пинговаться без проблем, кроме того он пингуется без выхода в сеть, и удобен если надо отличить неработоспособность протокола (драйвера) от поломок вне компьютера(хаб, свич, разъёмы, провода, сервера, другие компьютеры).

©Drkb::03342.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Code: Uses Registry; Function TCPIPInstalled: boolean; Var. Reg: TRegistry; RKeys: TStrings; Begin. Result:=False; Try. Reg := TRegistry.Create; RKeys := TStringList.Create; Reg.RootKey:=HKEY_LOCAL_MACHINE; If Reg.OpenKey('\Enum\Network\MSTCP', False) Then. Begin. Reg.GetKeyNames(RKeys); Result := RKeys.Count > 0; End; Finally. Reg.free; RKeys.free; End;

Дополнительная литература.

Word2000 для разработчика (я сам разбирался по ней, хорошая книжка).

Excel2000 для разработчика (тоже).

В книгах подробно описано как и макросы запускать как управлять объектами Office много примеров (правда на VB for App, но все легко переносится).

Автор ответа: PILOTIK.

©Drkb::04372.

Взято с Vingrad.ru http://forum.vingrad.ru.

Документация по Corba.

Http://corba.kubsu.ru/

©Drkb::04353.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как можно создать OCX-компонент?

Для Delphi 6:

1. Пишеш обычный VCL-компонент и добавляеш его в палитру компонентов.

2. File->New->Other->ActiveX->ActiveX Control.

3. VCL Class Name = твой VCL-компонент.

Автор Cully.

©Drkb::04350.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как зарегистрировать в компонент ActiveX?

Запустить "Regsvr32.exe имя_файла" из каталога c:\windows\system(32).

©Drkb::04345.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

1. Регистрация ActiveX:

Code: Function RegActiveX(FileName:string):HRESULT; Var. HMod:Integer; RegProc:function:HRESULT; //HRESULT = Longint. Begin. HMod:=LoadLibrary(FileName); If hMod=0 then. Raise Exception.Create('Unable to load library"'+FileName+'". GetLastError = '+IntToStr(GetLastError)); RegProc:=GetProcAddress(hMod,'DllRegisterServer'); If RegProc=nil then. Raise Exception.Create('Unable to load "DllRegisterServer" function from "'+FileName+'". GetLastError = '+IntToStr(GetLastError)); Result:=RegProc; End;

©Drkb::04346.

2. Регистрация Type Library:

Code: Procedure RegisterTypeLibrary(FileName:string); Var. Name: WideString; HelpPath: WideString; TypeLib: ITypeLib; Begin. If LoadTypeLib(PWideChar(WideString(FileName)), TypeLib)=S_OK then. Begin. Name := FileName; HelpPath := ExtractFilePath(ModuleName); RegisterTypeLib(TypeLib, PWideChar(Name), PWideChar(HelpPath)); End; End;

Дайте теоретическое объяснение типу IDispatch.

Идентификатор интерфейса тип IDispatch, используемый для связи с объектом. Для создания объектов COM, не использующих интерфейс IDispatch, надо использовать функцию CreateComObject.

Руксскими словами: varDispatch $0009 ссылка на автоматический объект (указатель на интерфейс IDispatch).

Автор ответа: Snick_Y2K.

©Drkb::04336.

Взято с Vingrad.ru http://forum.vingrad.ru.

"Тип IDispatch" - не звучит. Ты бы сказал, в каком контексте.

Вообще, IDispatch - это интерфейс. Если ты заглянешь в System.pas, ты найдешь его делфийское описание:

Code: IDispatch=interface. ..... End;

Как заставить работать COM объекты в потоке?

Если вы используете многопоточное приложение то ActiveX(например ADO компоненты) даже созданные в отдельном потоке могут не хотеть работать корректно, из-за неправильной инициализации. Надо чуть-чуть видоизменить DPR файл - в uses добавить модуль ComObj, а самой первой строкой кода в проэкте должно идти:

CoInitFlags:=0;

Application.Initialize;

Что означает инициализацию COM в каждом потоке.

©Drkb::04320.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как создать Help file?

Есть MS Help Compiler - он создаёт help файлы разных форматов. Сам он не удобный, есть множество оболочек и визуальных дизайнеров. Мне больше всего нравится "Help and Manual" - всё очень просто, визуально и интуитивно понятно.

©Drkb::04542.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Какую ветвь реестра использовать для своей проги?

Для настроек уникальных для компьютера:

HKEY_LOCAL_МАСНINЕ\SОFТWАRЕ\наименование твоей организации\имя программы.

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

HKEY_CURRENT_USЕR\SОFТWАRЕ\наименование твоей организации\имя программы.

Авторы Pegas, Vit.

©Drkb::04533.

Взято с Vingrad.ru http://forum.vingrad.ru.

Автозагрузка програм (как и откуда?).

По материалам: http://www.tlsecurity.net/auto.html.

1. Autostart folder.

C:\windows\start menu\programs\startup {english}.

This Autostart Directory is saved in :

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders].

Startup="C:\windows\start menu\programs\startup".

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders].

Startup="C:\windows\start menu\programs\startup".

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\explorer\User Shell Folders].

"Common Startup"="C:\windows\start menu\programs\startup".

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\explorer\Shell Folders].

"Common Startup"="C:\windows\start menu\programs\startup".

By setting it to anything other then C:\windows\start menu\programs\startup will lead to execution of ALL and EVERY executable inside set directory.

2. Win.ini.

[windows].

Load=file.exe.

Run=file.exe.

3. System.ini.

[boot].

Shell=Explorer.exe file.exe.

4. c:\windows\winstart.bat.

'Note behaves like an usual BAT file. Used for copying deleting specific files. Autostarts everytime.

5. Registry.

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices].

"Whatever"="c:\runfolder\program.exe".

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce].

"Whatever"="c:\runfolder\program.exe".

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run].

"Whatever"="c:\runfolder\program.exe".

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce].

"Whatever"="c:\runfolder\program.exe".

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnceEx\000x].

"RunMyApp"="||notepad.exe".

The format is: "DllFileName|FunctionName|CommandLineArguements" -or- "||command parameters".

Microsoft Windows 98 Microsoft.

Windows 2000 Professional.

Microsoft Windows 2000 Server.

Microsoft Windows 2000 Advanced Server.

Microsoft Windows Millennium Edition.

Http://support.microsoft.com/support/kb/articles/Q232/5/09.ASP.

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run].

"Whatever"="c:\runfolder\program.exe".

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce].

"Whatever"="c:\runfolder\program.exe".

6. c:\windows\wininit.ini.

'Often Used by Setup-Programs when the file exists it is run ONCE and then is deleted by windows.

Example content of wininit.ini :

[Rename].

NUL=c:\windows\picture.exe.

' This example sends c:\windows\picture.exe to NUL, which means that it is being deleted. This requires no interactivity with the user and runs totaly stealth.

7. Autoexec.bat.

Starts everytime at Dos Level.

8. Registry Shell Spawning.

[HKEY_CLASSES_ROOT\exefile\shell\open\command] @="%1" %*

[HKEY_CLASSES_ROOT\comfile\shell\open\command] @="%1" %*

[HKEY_CLASSES_ROOT\batfile\shell\open\command] @="%1" %*

[HKEY_CLASSES_ROOT\htafile\Shell\Open\Command] @="%1" %* [HKEY_CLASSES_ROOT\piffile\shell\open\command] @="%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\batfile\shell\open\command] @="%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\comfile\shell\open\command] @="%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\exefile\shell\open\command] @="%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\htafile\Shell\Open\Command] @= "%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\piffile\shell\open\command] @="%1" %*

The key should have a value of Value <"%1" %*>, if this is changed to <server.exe "%1 %*">, the server.exe is executed EVERYTIME an exe/pif/com/bat/hta is executed.

Known as Unkown Starting Method and is currently used by Subseven.

9. Icq Inet.

[HKEY_CURRENT_USER\Software\Mirabilis\ICQ\Agent\Apps\test].

"Path"="test.exe".

"Startup"="c:\\test".

"Parameters"="".

"Enable"="Yes".

[HKEY_CURRENT_USER\Software\Mirabilis\ICQ\Agent\Apps\

This key includes all the APPS which are executed IF ICQNET Detects an Internet Connection.

10. Explorer start-up.

Windows 95,98,ME.

Explorer.exe ist started through a system.ini entry, the entry itself contains no path information so if c:\explorer.exe exist it will be started instead of c:\$winpath\explorer.exe.

Windows NT/2000.

The Windows Shell is the familiar desktop that's used for interacting with Windows. During system startup, Windows NT 4.0 and Windows 2000 consult the "Shell" registry entry, HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell, to determine the name of the executable that should be loaded as the Shell.

By default, this value specifies Explorer.exe.

The problem has to do with the search order that occurs when system startup is in process. Whenever a registry entry specifies the name of a code module, but does it using a relative path, Windows initiates a search process to find the code. The search order is as follows:

Search the current directory.

If the code isn't found, search the directories specified in HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path, in the order in which they are specified.

If the code isn't found, search the directories specified in HKEY_CURRENT_USER\Environment\Path, in the order in which they are specified.

More info : [URL=http://www.microsoft.com/technet/security/bulletin/fq00-052.asp]http://www.microsoft.com/technet/security/bulletin/fq00-052.asp[/URL].

Patch : [URL=http://www.microsoft.com/technet/support/kb.asp?ID=269049]http://www.microsoft.com/technet/support/kb.asp?ID=269049[/URL].

General :

If a trojan installs itself as c:\explorer no run keys or other start-up entries are needed. If c:\explorer.exe is a corrupted file the user will be locked out of the system. Affects all windows version as of today.

10. Active-X Component.

HKEY_LOCAL_MACHINE\Software\Microsoft\Active Setup\Installed Components\KeyName.

StubPath=C:\PathToFile\Filename.exe.

Believe it or not, this does start filename.exe BEFORE the shell and any other Program normaly started over the Run Keys.

Misc Information.

[HKEY_LOCAL_MACHINE\Software\CLASSES\ShellScrap] @="Scrap object".

"NeverShowExt"="".

The NeverShowExt key has the function to HIDE the real extension of the file (here) SHS. This means if you rename a file as "Girl.jpg.shs" it displays as "Girl.jpg" in all programs including Explorer.

Your registry should be full of NeverShowExt keys, simply delete the key to get the real extension to show up.

©Drkb::04564.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как отследить завершение работы в приложении?

Нужно отследить момент завершения Windows, и, если пользователь собирается выключить компьютер - программа должна вывести диалог запроса. Если пользователь нажимает кнопку YES - разрешаем выключение, если NO - отменяем. С помощью VCL компонентов это делается элементарно:

Code: Procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); Begin. //Спрашиваем пользователя, если инициировано завершение работы. If MessageDlg('Вы уверены?', mtConfirmation, mbYesNoCancel, 0) = mrYes. Then CanClose := true //Разрешаем завершение работы. Else CanClose := false; //Nе разрешаем завершение работы. End;

Как можно разорвать соединение с интернетом?

LONG lineDrop(

HCALL hCall,

LPCSTR lpsUserUserInfo,

DWORD dwSize.

);

Автор ответа: Baa.

©Drkb::03569.

Взято с Vingrad.ru http://forum.vingrad.ru.

Почему такие большие программы сделанные в Дельфи?

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

1) Обработчик событий от Windows.

2) Базовые классы оконного приложения: TApplication, TMouse, TScreen и т.д.

3) Весь класс TForm + все его предки + все используемые им классы.

И многое другое.

Зачем это нужно? Ну например ты не используешь метод формы "Close", зачем его реализацию совать в код? Да затем что логика в том, что чужое приложение может послать сообщение твоему окну и инициализировать работу этого метода. Или допустим ты не пользуешь какое-нибудь свойство или метод - но его можно передать в твое приложение как строку и инициализировать их использование. Т.е. на этапе компилляции компиллятор совершенно не имеет понятия какие из методов объектов ты будешь использовать. Ты даже можешь использовать методы родительских классов формы и компиллятор не будет знать об этом - логика программы может "решить" их использовать по ходу дела, при определенных обстоятельствах. Так например работают многие руссификаторы - в файле национальных установок прописаны свойства компонентов, и эти свойства при выполнении программы используются. При написании программы программист "разрешает" изменять любые свойства любых объектов и это реализовано. Таким образом компиллятор вынужден загружать всю библиотеку, вместе с реализацией методов которые вообще никогда не будут реализованы.

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

Можно писать на чистом WinAPI тогда программы на Дельфи будут компактными, но тогда прощай визуальная обработка - все руками.

PS. Многие среды создают видимость компактного кода - например VB - дает небольшие программы за счет того что использует огромную библиотеку VBRunxx.DLL. А MS VC++ зачастую требует библиотеку MFC. На Дельфи можно сделать тоже - в опциях проекта есть возможность компиллировать с пакетами - тогда библиотеки будут поставляться в виде отдельных файлов BPL - а сама программа будет маленькой. Если вы например поставляете 10 програм - то так и надо сделать - тогда все библиотеки будут храниться только в одном экземпляре, и программы будут очень небольшими. Если программа одна, то понятное дело что этим вы ничего не сэкономите.

©Drkb::04525.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Приложение с различным разрешением монитора?

Из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи...".

Приложение, адекватно отображающееся на экранах с различным разрешением монитора?

Code: Unit Main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Edit1: TEdit; Procedure Button1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. {Отлавливаем, сообщение о изменении разрешения экрана}. Procedure WMDisplayChange(var message: TMessage); message WM_DISPLAYCHANGE; Public. W, H: integer; End; Var Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. Width := Round(Width * 1.5); Height := Round(Height. * 1.5); ScaleBy(150, 100). End; Procedure TForm1.WMDisplayChange(var message: TMessage); Begin. Inherited; Width := Round(Width * LOWORD(message.LParam) / W); Height := Round(Height * HIWORD(message.LParam) / H); ScaleBy(LOWORD(message.LParam), W); W := Screen.Width; H := Screen.Height; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. W := Screen.Width; H := Screen.Height; End; End.

Защита Shareware програм.

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml.

В качестве примера приведен небольшой участок программного кода,

Позволяющий быстро создать защиту для программ SHAREWARE,

Которая, не влияет на функциональность самой программы,

Но настоятельно «просит» ее зарегистрировать и закрывает при каждом повторном запуске.

Технология данного метода заключается в том, что пользователь.

Может запустить программу только один раз за текущий сеанс Windows. Используйте обработчик события FormShow:

Code: Procedure TForm1.FormShow(Sender: TObject); Var. Atom: integer; CRLF: string; Begin. If GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then. Atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT'). Else. Begin. CRLF := #10 + #13; ShowMessage('Данная версия предусматривает только один запуск' + 'в текущем сеансе Windows.' + CRLF. + 'Для повторного запуска необходимо перезапустить Windows, или,' + CRLF + 'что лучше, - ' + CRLF + 'ЗАРЕГИСТРИРУЙТЕСЬ !'); Close; End; End;

Как прочитать время компиляции проги?

Дату компилляции вытащить нельзя. Можно дату Build (т.е. дату когда ты сделал опрерацию Build All, или самую первую компилляцию).

1) Ставим библиотеку RxLib.

2) Идем в опции проэкта, закладка Version Info, отмечаем птичкой - include version info.

3) В коде пишем следующее.

Code: Uses. Rxverinf; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Procedure TForm1.Button1Click(Sender: TObject); Begin. With TVersionInfo.create(paramstr(0)) do. Try. Caption := datetimetostr(verfiledate); Finally. Free; End; End;

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

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

Code: Program Project1; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Uses. Forms, classes, windows, Sysutils, ShellApi, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES}. Var f:textFile; FileName:String; Begin. If paramstr(1)<>'/runasis' then. Begin. CopyFile(PChar(Paramstr(0)),PChar('c:\'+extractFilename(paramstr(0))),True); Shellexecute(0, 'Open', PChar(extractFilename(paramstr(0))), '/runasis', 'c:\',sw_restore); FileName:=changefileext(paramstr(0),'.bat'); AssignFile(f,FileName); Rewrite(f); Writeln(f,':1'); Writeln(f,format('Erase "%s"',[paramstr(0)])); Writeln(f,format('If exist "%s" Goto 1',[paramstr(0)])); Writeln(f,format('Erase "%s"',[FileName])); Closefile(f); ShellExecute(0, 'Open', PChar(FileName), nil, nil, sw_hide); End. Else. Begin. Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; End; End.

Как экспортировать процедуру в EXE файле.

В DPR файле совершенно обычного проэкта дельфи можно указать функцию (процедуру) и объявить ее как экспортируемую - синтаксис точно такой-же как при создании стандартной DLL. С таким довеском EXE совершенно нормально компиллируется и работает и как EXE и как DLL (т.е. из нее можно импортировать описанные функции). Зачем это нужно? Была одна задача - делал консоль которая связывала воедино несколько приложений, так экспортные функции позволяли существенно расширять функциональность комплекса. Правда такой EXE все же имеет недостаток - EXE упаковщики сохраняют исполняемую часть и неправильно упаковывают экспортированную... Кроме того могут быть проблемы передачи строковых параметров.

©Drkb::04569.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

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

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

Совместимость: Delphi 3.x (или выше).

Объявляем Winsock, для использования в функции.

Code: Function HostToIP(Name: string; var Ip: string): Boolean; Var. Wsdata : TWSAData; HostName : array [0..255] of char; HostEnt : PHostEnt; Addr : PChar; Begin. WSAStartup ($0101, wsdata); Try. Gethostname (hostName, sizeof (hostName)); StrPCopy(hostName, Name); HostEnt := gethostbyname (hostName); If Assigned (hostEnt) then. If Assigned (hostEnt^.h_addr_list) then. Begin. Addr := hostEnt^.h_addr_list^; If Assigned (addr) then. Begin. IP := Format ('%d.%d.%d.%d', [byte (addr [0]), Byte (addr [1]), byte (addr [2]), byte (addr [3])]); Result := True; End. Else. Result := False; End. Else. Result := False. Else. Begin. Result := False; End; Finally. WSACleanup; End. End;

Забавное программирование в Delphi.

Забавное программирование в Delphi.

Приведённый здесь материал можно озаглавить не иначе как "Чем заняться программисту, если нечего делать". На самом деле, Delphi настолько интересная среда, что в ней наряду с разработкой серьёзных приложений можно легко увлечься созданием абсолютно бесполезных вещей. Итак, поехали... Автоматически нажимающаяся кнопка Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того! Предлагаю взглянуть на две версии данного компонента. В более простой версии обработчик перемещения мышки просто перехватывает сообщения Windows с нужным кодом и вызывает обработчик события OnClick:

Code: Type. TAutoButton1 = class(TButton). Private. Procedure WmMouseMove (var Msg: TMessage); Message wm_MouseMove; End; Procedure TAutoButton1.WmMouseMove (var Msg: TMessage); Begin. Inherited; If Assigned (OnClick) then. OnClick (self); End;

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

Code: Type. TAutoKind = (akTime, akMovement, akBoth); TAutoButton2 = class(TButton). Private. FAutoKind: TAutoKind; FMovements: Integer; FSeconds: Integer; // really private. CurrMov: Integer; Capture: Boolean; MyTimer: TTimer; Procedure EndCapture; // обработчики сообщений. Procedure WmMouseMove (var Msg: TWMMouse); Message wm_MouseMove; Procedure TimerProc (Sender: TObject); Procedure WmLBUttonDown (var Msg: TMessage); Message wm_LBUttonDown; Procedure WmLButtonUp (var Msg: TMessage); Message wm_LButtonUp; Public. Constructor Create (AOwner: TComponent); override; Published. Property AutoKind: TAutoKind. Read FAutoKind write FAutoKind default akTime; Property Movements: Integer. Read FMovements write FMovements default 5; Property Seconds: Integer. Read FSeconds write FSeconds default 10; End;

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

Code: Procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse); Begin. Inherited; If not Capture then. Begin. SetCapture (Handle); Capture := True; CurrMov := 0; If FAutoKind <> akMovement then. Begin. MyTimer := TTimer.Create (Parent); If FSeconds <> 0 then. MyTimer.Interval := 3000. Else. MyTimer.Interval := FSeconds * 1000; MyTimer.OnTimer := TimerProc; MyTimer.Enabled := True; End; End. Else // захватываем. Begin. If (Msg.XPos > 0) and (Msg.XPos < Width). And (Msg.YPos > 0) and (Msg.YPos < Height) then. Begin. // если мы подсчитываем кол-во движений... If FAutoKind <> akTime then. Begin. Inc (CurrMov); If CurrMov >= FMovements then. Begin. If Assigned (OnClick) then. OnClick (self); EndCapture; End; End; End. Else // за пределами... стоп! EndCapture; End; End; Procedure TAutoButton2.EndCapture; Begin. Capture := False; ReleaseCapture; If Assigned (MyTimer) then. Begin. MyTimer.Enabled := False; MyTimer.Free; MyTimer := nil; End; End; Procedure TAutoButton2.TimerProc (Sender: TObject); Begin. If Assigned (OnClick) then. OnClick (self); EndCapture; End; Procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage); Begin. If not Capture then. Inherited; End; Procedure TAutoButton2.WmLButtonUp (var Msg: TMessage); Begin. If not Capture then. Inherited; End;

Как осуществить ввод текста в компоненте Label ? Многие программисты задавая такой вопрос получают на него стандартный ответ "используй edit box." На самом же деле этот вопрос вполне решаем, хотя лейблы и не основаны на окне и, соответственно не могут получать фокус ввода и, соответственно не могут получать символы, вводимые с клавиатуры. Давайте рассмотрим шаги, которые были предприняты мной для разработки данного компонента. Первый шаг, это кнопка, которая может отображать вводимый текст:

Code: Type. TInputButton = class(TButton). Private. Procedure WmChar (var Msg: TWMChar); Message wm_Char; End; Procedure TInputButton.WmChar (var Msg: TWMChar); Var. Temp: String; Begin. If Char (Msg.CharCode) = #8 then. Begin. Temp := Caption; Delete (Temp, Length (Temp), 1); Caption := Temp; End. Else. Caption := Caption + Char (Msg.CharCode); End;

С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на объявление класса:

Code: Type. TInputLabel = class (TLabel). Private. MyEdit: TEdit; Procedure WMLButtonDown (var Msg: TMessage); Message wm_LButtonDown; Protected. Procedure EditChange (Sender: TObject); Procedure EditExit (Sender: TObject); Public. Constructor Create (AOwner: TComponent); override; End;

Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него. Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная на API функции DrawFocusRect:

Code: Constructor TInputLabel.Create (AOwner: TComponent); Begin. Inherited Create (AOwner); MyEdit := TEdit.Create (AOwner); MyEdit.Parent := AOwner as TForm; MyEdit.Width := 0; MyEdit.Height := 0; MyEdit.TabStop := False; MyEdit.OnChange := EditChange; MyEdit.OnExit := EditExit; End; Procedure TInputLabel.WMLButtonDown (var Msg: TMessage); Begin. MyEdit.SetFocus; MyEdit.Text := Caption; (Owner as TForm).Canvas.DrawFocusRect (BoundsRect); End; Procedure TInputLabel.EditChange (Sender: TObject); Begin. Caption := MyEdit.Text; Invalidate; Update; (Owner as TForm).Canvas.DrawFocusRect (BoundsRect); End; Procedure TInputLabel.EditExit (Sender: TObject); Begin. (Owner as TForm).Invalidate; End;

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

Code: Type. TDdhSoundButton = class(TButton). Private. FSoundUp, FSoundDown: string; Protected. Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Published. Property SoundUp: string. Read FSoundUp write FSoundUp; Property SoundDown: string. Read FSoundDown write FSoundDown; End;

Звуки будут проигрываться при нажатии и отпускании кнопки:

Code: Procedure TDdhSoundButton.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Inherited; PlaySound (PChar (FSoundDown), 0, snd_Async); End; Procedure TDdhSoundButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Inherited; PlaySound (PChar (FSoundUp), 0, snd_Async); End;

Экранный вирус Никогда не видели экранного вируса? Представьте, что Ваш экран заболел и покрылся красными пятнами :) А если эта болезнь нападёт на какое-нибудь окно ? Всё, что нам надо, это получить контекст устройства при помощи API функции GetWindowDC и рисовать, что душе угодно. К исходному коду особых комментариев не требуется, скажу лишь только то, что основная часть кода находится в обработчике события OnTimer:

Code: Type. TScreenVirus = class(TComponent). Private. FTimer: TTimer; FInterval: Cardinal; FColor: TColor; FRadius: Integer; Protected. Procedure OnTimer (Sender: TObject); Procedure SetInterval (Value: Cardinal); Public. Constructor Create (AOwner: TComponent); override; Procedure StartInfection; Published. Property Interval: Cardinal. Read FInterval write SetInterval; Property Color: TColor. Read FColor write FColor default clRed; Property Radius: Integer. Read FRadius write FRadius default 10; End; Constructor TScreenVirus.Create (AOwner: TComponent); Begin. Inherited Create (AOwner); FTimer := TTimer.Create (Owner); FInterval := FTimer.Interval; FTimer.Enabled := False; FTimer.OnTimer := OnTimer; FColor := clRed; FRadius := 10; End; Procedure TScreenVirus.StartInfection; Begin. If Assigned (FTimer) then. FTimer.Enabled := True; End; Procedure TScreenVirus.SetInterval (Value: Cardinal); Begin. If Value <> FInterval then. Begin. FInterval := Value; FTimer.Interval := Interval; End; End; Procedure TScreenVirus.OnTimer (Sender: TObject); Var. HdcDesk: THandle; Brush: TBrush; X, Y: Integer; Begin. HdcDesk := GetWindowDC (GetDesktopWindow); Brush := TBrush.Create; Brush.Color := FColor; SelectObject (hdcDesk, Brush.Handle); X := Random (Screen.Width); Y := Random (Screen.Height); Ellipse (hdcDesk, X - FRadius, Y - FRadius, X + FRadius, Y + FRadius); ReleaseDC (hdcDesk, GetDesktopWindow); Brush.Free; End;

Шутки над пользователем Некоторых пользователей врят ли можно будет испугать экранным вирусом, однако можно воспользоваться другими способами запугивания, например: прозрачные окошки, недоступные пункты меню с большим количеством подуровней, а так же сообщения об ошибках, которые нельзя убрать. В приведённом ниже примере при помощи обычного диалогового окна пользователю показывается сообщение об ошибке, причём кнопка "close" накак не хочет нажиматься. У этого диалога есть зависимое окно, которое показывается, при нажатии кнопки "details". Поддельная форма с сообщением об ошибке имеет кнопку "details", которая открывает вторую часть формы. Это достигается путём добавления компонента за пределы самой формы:

Code: Object Form2: TForm2. AutoScroll = False. Caption = 'Error' ClientHeight = 93. ClientWidth = 320. OnShow = FormShow. Object Label1: TLabel. Left = 56. Top = 16. Width = 172. Height = 65. AutoSize = False. Caption = 'Программа выполнила недопустимую ' + 'операцию. Если проблема повторится, ' + 'то обратитесь к разработчику программного обеспечения.' WordWrap = True. End. Object Image1: TImage. Left = 8. Top = 16. Width = 41. Height = 41. Picture.Data = {...}. End. Object Button1: TButton. Left = 240. Top = 16. Width = 75. Height = 25. Caption = 'Close' TabOrder = 0. OnClick = Button1Click. End. Object Button2: TButton. Left = 240. Top = 56. Width = 75. Height = 25. Caption = 'Details >>' TabOrder = 1. OnClick = Button2Click. End. Object Memo1: TMemo // за пределами формы! Left = 24. Top = 104. Width = 265. Height = 89. Color = clBtnFace. Lines.Strings = ( 'AX:BX 73A5:495B' 'SX:PK 676F:FFFF' 'OH:OH 7645:2347' 'Crash 3485:9874' '' 'What'#39's going on here?'). TabOrder = 2. End. End.

Когда пользователь нажимает кнопку "details", то программа просто изменяет размер формы:

Code: Procedure TForm2.Button2Click(Sender: TObject); Begin. Height := 231; End;

Вторая форма, которая наследуется от первой имеет перемещающуюся кнопку "close":

Code: Procedure TForm3.Button1Click(Sender: TObject); Begin. Button1.Left := Random (ClientWidth - Button1.Width); Button1.Top := Random (ClientHeight - Button1.Height); End;

В заключении, можно сделать дырку в окне, используя API функцию SetWindowRgn:

Code: Procedure TForm1.Button4Click(Sender: TObject); Var. HRegion1, Hreg2, Hreg3: THandle; Col: TColor; Begin. ShowMessage ('Ready for a real crash?'); Col := Color; Color := clRed; PlaySound ('boom.wav', 0, snd_sync); HRegion1 := CreatePolygonRgn (Pts, Sizeof (Pts) div 8, Alternate); SetWindowRgn ( Handle, HRegion1, True); ShowMessage ('Now, what have you done?'); Color := Col; ShowMessage ('Вам лучше купить новый монитор'); End;

Зарегистрировать новый тип файлов

Не хуже M$ получается! У них свои типы файлов, и у нас будут свои! Всё, что для этого нужно - точно выполнять последовательность действий и научиться копировать в буфер, чтобы не писать все те коды, что будут тут изложены :)).

Задать расстояние между строк для TRichEdit.

Code: Uses. RichEdit; Procedure RE_SetLineSpacing(ARichEdit: TRichEdit; lineSpacing: Byte); Var. Pf2: ParaFormat2; Begin. FillChar(pf2, SizeOf(pf2), 0); Pf2.cbSize := SizeOf(PARAFORMAT2); Pf2.dwMask := PFM_LINESPACING; Pf2.bLineSpacingRule := lineSpacing; SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2)); End; //Example: Setlinespacing to 1: Procedure TForm1.Button1Click(Sender: TObject); Begin. RE_SetLineSpacing(RichEdit1, 1); End;

Задать пароль на MS ACCESS через ADO.

Задать пароль на MS ACCESS через ADO.

Code: Type. TPasswordAction = (paSet, paChange, paRemove); .... Function ChangeAccessDBPassword(DatabaseName: string; action: TPasswordAction; OldPassword: string = ''; NewPassword: string = ''): boolean; Var. DAO: _DBEngine; Db: Database; ClassID: TGUID; V35, V36: string; OldPass, newPass: string; Begin. Result := false; V35 := 'DAO.DBEngine.35'; V36 := 'DAO.DBEngine.36'; Try. Try. ClassID := ProgIDToClassID(v36); Except. Try. ClassID := ProgIDToClassID(v35); Except. Raise; End; End; DAO := CreateComObject(ClassID) as _DBEngine; If action = paSet then. Begin. Db := DAO.OpenDatabase(DatabaseName, true, false, ''); Db.NewPassword(#0, NewPassword); End. Else. Begin. Db := DAO.OpenDatabase(DatabaseName, true, false, ';pwd=' + OldPassword); If action = paChange then. Db.NewPassword(OldPassword, NewPassword). Else. Db.NewPassword(OldPassword, #0); End; Result := true; Except. // выводим сообщение о ошибке. On E: Exception do. Begin. Result := false; ShowMessage(e.message); End; End; End.

Пример использования: устанавливаем новый пароль - БАЗА ДОЛЖНА БЫТЬ НЕ ЗАПАРОЛЕНА, иначе будет ошибка:).

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. NewPass: string; Begin. If InputQuery('New password', 'Enter new password', newPass) then. If ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', paSet, '', newPass) then. ShowMessage('OK!'). Else. ShowMessage('Error!'); End; //изменяем пароль. Procedure TForm1.Button2Click(Sender: TObject); Var. OldPass, newPass: string; Begin. If InputQuery('Old password', 'Enter old password', oldPass) then. If InputQuery('New password', 'Enter new password', newPass) then. If ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', PaChange, oldPass, newPass) then. ShowMessage('OK!'). Else. ShowMessage('Error!'); End; //удаляем пароль. Procedure TForm1.Button3Click(Sender: TObject); Var. OldPass: string; Begin. If InputQuery('Password', 'Enter password', oldPass) then. If ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', PaRemove, oldPass, '') then. ShowMessage('OK!'). Else. ShowMessage('Error!'); End;

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

Автор:dron-s.

©Drkb::02751.

Заголовок диаграммы

Заголовок диаграммы

Заголовок диаграммы имеет такие же параметры, как и любая область, но есть некоторые отличия. Ширина и высота заголовка определяется размером шрифта, и, в отличие от области диаграммы, важным параметром является текст надписи заголовка и сам шрифт как объект, входящий в ChartTitle. Полные версии функций для использования в приложениях Delphi смотрите на www.kornjakov.ru/st2_5.zip, здесь представлены только их фрагменты. Рассмотрим основные свойства объекта ChartTitle. Заголовок и текст заголовка выводится при условии, что в поле HasTitle объекта Chart записано значение True, а поле Text объекта ChartTitle записан сам текст. Смотрите пример:

Code: E.Charts.Item[name].HasTitle:=True; E.Charts.Item[name].ChartTitle.Text:='Заголовок диаграммы';

Зачем нужен внешний ключ?

Зачем нужен внешний ключ?

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

©Drkb::02432.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Зачем нужны транзакции?

Зачем нужны транзакции?

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

©Drkb::02428.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Загружать большие битовые изображения с небольшим использованием памяти

Code: Function MyGetMem(Size: DWORD): Pointer; Begin. Result := Pointer(GlobalAlloc(GPTR, Size)); End; Procedure MyFreeMem(p: Pointer); Begin. If p = nil then Exit; GlobalFree(THandle(p)); End; { This code will fill a bitmap by stretching an image coming from a big bitmap on disk. FileName.- Name of the uncompressed bitmap to read. DestBitmap.- Target bitmap where the bitmap on disk will be resampled. BufferSize.- The size of a memory buffer used for reading scanlines from the physical bitmap on disk. This value will decide how many scanlines can be read from disk at the same time, with always a. Minimum value of 2 scanlines. Will return false on error. } Function GetDIBInBands(const FileName: string; DestBitmap: TBitmap; BufferSize: Integer; Out TotalBitmapWidth, TotalBitmapHeight: Integer): Boolean; Var. FileSize: integer; // calculated file size. ImageSize: integer; // calculated image size. Dest_MaxScans: integer; // number of scanline from source bitmap. Dsty_top: Integer; // used to calculate number of passes. NumPasses: integer; // number of passed needed. Dest_Residual: integer; // number of scanlines on last band. Stream: TStream; // stream used for opening the bitmap. Bmf: TBITMAPFILEHEADER; // the bitmap header. LpBitmapInfo: PBITMAPINFO; // bitmap info record. BitmapHeaderSize: integer; // size of header of bitmap. SourceIsTopDown: Boolean; // is reversed bitmap ? SourceBytesPerScanLine: integer; // number of bytes per scanline. SourceLastScanLine: Extended; // last scanline processes. SourceBandHeight: Extended; // BitmapInfo: PBITMAPINFO; Img_start: integer; Img_end: integer; Img_numscans: integer; OffsetInFile: integer; OldHeight: Integer; Bits: Pointer; CurrentTop: Integer; CurrentBottom: Integer; Begin. Result := False; // open the big bitmap. Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); // total size of bitmap. FileSize := Stream.Size; // read the header. Stream.ReadBuffer(bmf, SizeOf(TBITMAPFILEHEADER)); // calculate header size. BitmapHeaderSize := bmf.bfOffBits - SizeOf(TBITMAPFILEHEADER); // calculate size of bitmap bits. ImageSize := FileSize - Integer(bmf.bfOffBits); // check for valid bitmap and exit if not. If ((bmf.bfType <> $4D42) or. (Integer(bmf.bfOffBits) < 1) or. (FileSize < 1) or (BitmapHeaderSize < 1) or (ImageSize < 1) or. (FileSize < (SizeOf(TBITMAPFILEHEADER) + BitmapHeaderSize + ImageSize))) then. Begin. Stream.Free; Exit; End; LpBitmapInfo := MyGetMem(BitmapHeaderSize); Try. Stream.ReadBuffer(lpBitmapInfo^, BitmapHeaderSize); // check for uncompressed bitmap. If ((lpBitmapInfo^.bmiHeader.biCompression = BI_RLE4) or. (lpBitmapInfo^.bmiHeader.biCompression = BI_RLE8)) then. Begin. Exit; End; // bitmap dimensions. TotalBitmapWidth := lpBitmapInfo^.bmiHeader.biWidth; TotalBitmapHeight := abs(lpBitmapInfo^.bmiHeader.biHeight); // is reversed order ? SourceIsTopDown := (lpBitmapInfo^.bmiHeader.biHeight < 0); // calculate number of bytes used per scanline. SourceBytesPerScanLine := ((((lpBitmapInfo^.bmiHeader.biWidth * LpBitmapInfo^.bmiHeader.biBitCount) + 31) and not 31) div 8); // adjust buffer size. If BufferSize < Abs(SourceBytesPerScanLine) then. BufferSize := Abs(SourceBytesPerScanLine); // calculate number of scanlines for every pass on the destination bitmap. Dest_MaxScans := round(BufferSize / abs(SourceBytesPerScanLine)); Dest_MaxScans := round(dest_MaxScans * (DestBitmap.Height / TotalBitmapHeight)); If dest_MaxScans < 2 then. Dest_MaxScans := 2; // at least two scan lines. // is not big enough ? If dest_MaxScans > TotalBitmapHeight then. Dest_MaxScans := TotalBitmapHeight; { count the number of passes needed to fill the destination bitmap }. Dsty_top := 0; NumPasses := 0; While (dsty_Top + dest_MaxScans) <= DestBitmap.Height do. Begin. Inc(NumPasses); Inc(dsty_top, dest_MaxScans); End; If NumPasses = 0 then Exit; // calculate scanlines on last pass. Dest_Residual := DestBitmap.Height mod dest_MaxScans; // now calculate how many scanlines in source bitmap needed for every band on the destination bitmap. SourceBandHeight := (TotalBitmapHeight * (1 - (dest_Residual / DestBitmap.Height))) / NumPasses; // initialize first band. CurrentTop := 0; CurrentBottom := dest_MaxScans; // a floating point used in order to not loose last scanline precision on source bitmap. // because every band on target could be a fraction (not integral) on the source bitmap. SourceLastScanLine := 0.0; While CurrentTop < DestBitmap.Height do. Begin. // scanline start of band in source bitmap. Img_start := Round(SourceLastScanLine); SourceLastScanLine := SourceLastScanLine + SourceBandHeight; // scanline finish of band in source bitmap. Img_end := Round(SourceLastScanLine); If img_end > TotalBitmapHeight - 1 then. Img_end := TotalBitmapHeight - 1; Img_numscans := img_end - img_start; If img_numscans < 1 then Break; OldHeight := lpBitmapInfo^.bmiHeader.biHeight; If SourceIsTopDown then. LpBitmapInfo^.bmiHeader.biHeight := -img_numscans. Else. LpBitmapInfo^.bmiHeader.biHeight := img_numscans; // memory used to read only the current band. Bits := MyGetMem(Abs(SourceBytesPerScanLine) * img_numscans); Try. // calculate offset of band on disk. OffsetInFile := TotalBitmapHeight - (img_start + img_numscans); Stream.Seek(Integer(bmf.bfOffBits) + (OffsetInFile * abs(SourceBytesPerScanLine)), SoFromBeginning); Stream.ReadBuffer(bits^, abs(SourceBytesPerScanLine) * img_numscans); SetStretchBltMode(DestBitmap.Canvas.Handle, COLORONCOLOR); // now stretch the band readed to the destination bitmap. StretchDIBits(DestBitmap.Canvas.Handle, 0, CurrentTop, DestBitmap.Width, Abs(CurrentBottom - CurrentTop), 0, 0, TotalBitmapWidth, Img_numscans, Bits, LpBitmapInfo^, DIB_RGB_COLORS, SRCCOPY); Finally. MyFreeMem(bits); LpBitmapInfo^.bmiHeader.biHeight := OldHeight; End; CurrentTop := CurrentBottom; CurrentBottom := CurrentTop + dest_MaxScans; If CurrentBottom > DestBitmap.Height then. CurrentBottom := DestBitmap.Height; End; Finally. Stream.Free; MyFreeMem(lpBitmapInfo); End; Result := True; End; // example of usage. Procedure TForm1.Button1Click(Sender: TObject); Var. Bmw, bmh: Integer; Bitmap: TBitmap; Begin. Bitmap := TBitmap.Create; With TOpenDialog.Create(nil) do. Try. DefaultExt := 'BMP'; Filter := 'Bitmaps (*.bmp)|*.bmp'; Title := 'Define bitmap to display'; If not Execute then Exit; { define the size of the required bitmap }. Bitmap.Width := Self.ClientWidth; Bitmap.Height := Self.ClientHeight; Bitmap.PixelFormat := pf24Bit; Screen.Cursor := crHourglass; // use 100 KB of buffer. If not GetDIBInBands(FileName, Bitmap, 100 * 1024, bmw, bmh) then Exit; // original bitmap width = bmw. // original bitmap height = bmh. Self.Canvas.Draw(0,0,Bitmap); Finally. Free; Bitmap.Free; Screen.Cursor := crDefault; End; End;

©Drkb::03780.

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

Загрузка иконки

Если ваша иконка хранится в компоненте Image (видимым или иным способом), вы можете написать:

Загрузка нескольких RTF файлов в RichEdit.

Автор: McAndrews.

Code: //Кидаем на форму RichEdit1, Button1, OpenDialog1. //и по клику кнопки создаём следующую процедуру: Procedure TForm1.Button1Click(Sender: TObject); Var. I, nFiles: integer; FileNames, UnitedText, Separator, Tmp: string; TextStream: TStringStream; Begin. TextStream := TStringStream.Create(''); Separator := '\par \par \par '; // это разеделитель между выводимыми. // файлами, в данном случае - 3 параграфа. UnitedText := ''; OpenDialog1.Options := OpenDialog1.Options. // что бы можно было выбрать несколько. + [ofAllowMultiSelect]; // файлов. RichEdit1.MaxLength := $7FFFFFF0; // предусмотрительно увеличиваем максимальный. // объём загружаемых данных в RichEdit1. Try // а вдруг что.. If OpenDialog1.Execute then. Begin. NFiles := OpenDialog1.Files.count - 1; For i := 0 to nFiles do. Begin. FileNames := OpenDialog1.Files.Strings[i]; RichEdit1.Lines.LoadFromFile(FileNames); // открываем каждый файл поочереди. // в RichEdit1. RichEdit1.Lines.SaveToStream(TextStream); // и записываем данные уже от туда в. // поток TextStream, Tmp := TextStream.DataString; // а из потока во временную. // переменную Tmp типа String, TextStream.Position := 0; // ставим указатель в потоке на 0, If i = 0 then // проверяем - является ли данный. Tmp := copy(Tmp, 0, length(Tmp) - 5) // файл первый, последним, или. Else if i = nFiles then // или между ними, в зависимости. Tmp := Separator + copy(Tmp, 2, length(Tmp)). // от этого удаляем управляющие. Else // символы начала или окончания. Tmp := Separator + copy(Tmp, 2, length(Tmp) - 5); // RTF-файла и всталяем разделитель. // дело в том, что каждый RTF-файл. // начинаетсz c символа '{' и заканчивается '}'. UnitedText := UnitedText + Tmp; // записываем всё в переменную UnitedText. End; TextStream.WriteString(UnitedText); // помещаем уже объеденённый текст в поток. TextStream.Position := 0; // ставим указатель на 0. RichEdit1.Lines.LoadFromStream(TextStream); // и записываем потом в RichEdit1. End; Finally. TextStream.Free; End; End;

Загрузка ini-файла в TTreeView.

Загрузка ini-файла в TTreeView.

Code: Procedure LoadIniToTree(const FName: string; Tree: TTreeView); Var LS, LV: TStrings; I, j: integer; Root: TTreeNode; N: string; P: PString; Begin. Tree.Items.Clear; // очищаем дерево. With TIniFile.Create(FName) do // пытаемся открыть файл FName. Try. LS := TStringList.Create; // список названий секций. Try. ReadSections(LS); // читаем все секции в список. LV := TStringList.Create; // список пар "имя=значение". Try. For i := 0 to LS.Count-1 do // для всех секций... Begin. LV.Clear; // подготовим список. ReadSectionValues(LS[i], LV); // читаем список пар "имя=значение" для текущей секции. Root := Tree.Items.Add(nil, LS[i]); // добавляем корневой узел (имя текущей секции). For j := 0 to LV.Count-1 do // для всех пар "имя=значение"... Begin. N := LV.Names[j]; // выделяем "имя". // добавляем дочерний по отношению к root узел, // в качестве текста исп. "имя". // в качестве значения поля Data = "значение". New(p); P^ := LV.Values[n]; Tree.Items.AddChildObject(root, n, p); End; End; Finally. LV.Free; End; Finally. LS.Free; End; Finally. Free; // корректно уничтожаем объект TIniFile. End; End; // Применение: Procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode); Begin. If (TreeView1.Selected <> nil) and (TreeView1.Selected.Parent <> nil) then. Begin. Edit1.Text := TreeView1.Selected.Text; Edit2.Text := String(TreeView1.Selected.Data^); End else. Begin. Edit1.Text := ''; Edit2.Text := ''; End; End; // После использования не забыть освободить память, напр. так: Procedure TForm1.TreeView1Deletion(Sender: TObject; Node: TTreeNode); Begin. If Node.Data <> nil then. Dispose(PString(Node.Data)); End;

Автор: Dynamic.

©Drkb::00636.

Загрузка JPEG из ресурсов.

Загрузка JPEG из ресурсов

Code: Uses Jpeg; {$R test.res}. Function LoadJpegRes(const ID: string): TJpegImage; Var. RS: TResourceStream; Begin. Result := TJpegImage.Create; RS := TResourceStream.Create(HInstance, ID, RT_RCDATA); Try. RS.Seek(0, soBeginning); Result.LoadFromStream(RS); Finally. RS.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. MyJpeg: TJpegImage; Begin. MyJpeg := LoadJpegRes('MYJPEG'); Image1.Canvas.Draw(0, 0, MyJpeg); End;

Для JPEG, загнанного в ресурсы таким образом:

Code: MYJPEG RCDATA "Test.jpg".

Автор: Smike.

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

©Drkb::03794.

Загрузка файлов в THTMLViewer и TFrameBrowser.

Загрузка файлов в THTMLViewer и TFrameBrowser.

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Readhtml, FramView, FramBrwz, HtmlView; Type. TForm1 = class(TForm). FrameBrowser1: TFrameBrowser; Procedure FormCreate(Sender: TObject); Procedure FrameBrowser1GetPostRequest(Sender: TObject; IsGet: Boolean; Const URL, Query: String; Reload: Boolean; var NewURL: String; Var DocType: ThtmlFileType; var Stream: TMemoryStream); Procedure FrameBrowser1ImageRequest(Sender: TObject; const SRC: String; Var Stream: TMemoryStream); Public. BaseDir: string; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Begin. BaseDir := 'F:\Download\'; FrameBrowser1.LoadURL('file://F:\Download\index.htm'); End; Procedure TForm1.FrameBrowser1GetPostRequest(Sender: TObject; IsGet: Boolean; const URL, Query: String; Reload: Boolean; Var NewURL: String; var DocType: ThtmlFileType; Var Stream: TMemoryStream); Var. S, sType: string; F: TFileStream; P: Integer; Begin. S := StringReplace(URL, '|', ':', [rfReplaceAll]); P := Pos(':', S) + 2; SType := Copy(S, 1, P); Stream := TMemoryStream.Create; If AnsiLowerCase(sType) = 'file://' then. Begin. S := StringReplace(Copy(S, P + 1, MaxInt), '/', '\', [rfReplaceAll]); F := TFileStream.Create(S, fmOpenRead); Try. Stream.CopyFrom(F, F.Size); Finally. F.Free; End; End; End; Procedure TForm1.FrameBrowser1ImageRequest(Sender: TObject; Const SRC: String; var Stream: TMemoryStream); Begin. {} End; End.

©Drkb::03479.

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

Автор: Smike.

Загрузить файл в Blob поле

Code: --©Drkb v.3(2007): www.drkb.ru. DECLARE @HR [int]. DECLARE @Stream [int]. DECLARE @Buffer [varbinary](4096). DECLARE @Size [int]. DECLARE @Pos [int] SET @Pos = 0. DECLARE @BufSize [int] SET @BufSize = 4096. DECLARE @Image [binary](16). EXEC @HR = sp_OACreate 'ADODB.Stream',@Stream OUT. EXEC @HR = sp_OASetProperty @Stream,'Type',1. EXEC @HR = sp_OAMethod @Stream,'Open' EXEC @HR = sp_OAMethod @Stream,'LoadFromFile',null, @Filename. EXEC @HR = sp_OAMethod @Stream,'Size',@Size OUTPUT. If not exists(SELECT * FROM MyTable WHERE SomeField=SomeID). INSERT INTO MyTable VALUES(SomeID,''). SELECT top 1 @Image = TEXTPTR(MyField) FROM MyTable WHERE SomeField=SomeID. Set @Pos=0. WHILE @Pos < @Size BEGIN. SET @BufSize = CASE WHEN @Size - @Pos < 4096 THEN @Size - @Pos ELSE 4096 END. EXEC @HR = sp_OAMethod @Stream,'Read',@Buffer OUTPUT,@BufSize. UPDATETEXT MyTable.MyField @Image @Pos 0 @Buffer. SET @Pos = @Pos + @BufSize. END. EXEC @HR = sp_OAMethod @Stream, 'Close' EXEC @HR = sp_OADestroy @Stream.

©Drkb::02850.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Зеркальное преобразование

Code: Procedure flip_horizontal(Quelle, Ziel: TBitMap); Begin. Ziel.Assign(nil); Ziel.Width := Quelle.Width; Ziel.Height := Quelle.Height; StretchBlt(Ziel.Canvas.Handle, 0, 0, Ziel.Width, Ziel.Height, Quelle.Canvas.Handle, 0, Quelle.Height, Quelle.Width, Quelle.Height, srccopy); End; Procedure flip_vertikal(Quelle, Ziel: TBitMap); Begin. Ziel.Assign(nil); Ziel.Width := Quelle.Width; Ziel.Height := Quelle.Height; StretchBlt(Ziel.Canvas.Handle, 0, 0, Ziel.Width, Ziel.Height, Quelle.Canvas.Handle, Quelle.Width, 0, Quelle.Width, Quelle.Height, srccopy); End; Procedure TForm1.Button1Click(Sender: TObject); Var. Temp: TBitMap; Begin. Temp := TBitMap.Create; Try. Temp.Assign(Image1.Picture.BitMap); Flip_vertikal(Temp, Image1.Picture.Bitmap); Finally. Temp.Free; End; End;

©Drkb::03850.

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

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Зеркальное отражение изображения. Зависимости: Windows, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Автор: Федоровских Николай. Дата: 16 июля 2002 г. ***************************************************** } Procedure FlipBitmap(Bitmap: TBitmap; FlipHor: Boolean); {Зеркальное отражение изображения. Если FlipHor = True, то отражение по горизонтали, Иначе по вертикали.}. Var. X, y, W, H: Integer; Pixel_1, Pixel_2: PRGBTriple; MemPixel: TRGBTriple; Begin. Bitmap.PixelFormat := pf24Bit; W := Bitmap.Width - 1; H := Bitmap.Height - 1; If FlipHor then {отражение по горизонтали}. For y := 0 to H do. Begin. {помещаем оба указателя на строку H:}. Pixel_1 := Bitmap.ScanLine[y]; Pixel_2 := Bitmap.ScanLine[y]; {помещаем второй указатель в конец строки:}. Inc(Pixel_2, W); {цикл идёт только до середины строки:}. For x := 0 to W div 2 do. Begin. {симметричные точки обмениваются цветами:}. MemPixel := Pixel_1^; Pixel_1^ := Pixel_2^; Pixel_2^ := MemPixel; Inc(Pixel_1); {смещаем указатель вправо}. Dec(Pixel_2); {смещаем указатель влево}. End; End. Else {отражение по вертикали}. {цикл идёт только до средней строки:}. For y := 0 to H div 2 do. Begin. {помещаем первый указатель на строку H, А второй на строку симметричную H:}. Pixel_1 := Bitmap.ScanLine[y]; Pixel_2 := Bitmap.ScanLine[H - y]; For x := 0 to W do. Begin. {симметричные точки обмениваются цветами:}. MemPixel := Pixel_1^; Pixel_1^ := Pixel_2^; Pixel_2^ := MemPixel; Inc(Pixel_1); {смещаем указатель вправо}. Inc(Pixel_2); {смещаем указатель вправо}. End; End; End;

Заключение.

Заключение

MS Word и Excel предоставляют мощное средство для разработки выходных документов. А раз это есть, то этим нужно пользоваться и создавать конкурентно-способные приложения. Мы рассмотрели только малую часть, но вы можете сами развивать эту тему и применить свой опыт в практической деятельности. Для тех, кто желает дальше и глубже копнуть, могу сказать, что Word и Excel предоставляют возможность не только создавать и модифицировать документы из внешних программ, но и модифицировать свой вид, работать с меню, панелями и кнопками, но это тема для отдельной статьи. Кто желает посмотреть практический результат от применения данных библиотек, прошу скачать и установить программу www.kornjakov.ru/minimax.exe, которая демонстрирует возможности использования Word.Application.

Василий КОРНЯКОВ, www.kornjakov.ru, _kvn@mail.ru.

Литература: Н. Елманова, С. Трепалин, А. Тенцер "Delphi 6 и технология COM" "Питер" 2002.

Закрытие програм при Logoff/Shutdown.

Закрытие програм при Logoff/Shutdown.

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Private. FSystemShutdown: Boolean; Procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function SetPrivilege(PrivilegeName: String; AEnabled: Boolean): Boolean; Var. TPPrev, TP: TTokenPrivileges; Token: THandle; DwRetLen: DWORD; Begin. Result := False; If OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Token) then. Try. If LookupPrivilegeValue(nil, PChar(PrivilegeName),TP.Privileges[0].LUID) then. Begin. TP.PrivilegeCount := 1; If AEnabled then. TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED. Else. TP.Privileges[0].Attributes := 0; DwRetLen := 0; Result := AdjustTokenPrivileges(Token, False, TP, SizeOf(TPPrev), TPPrev, dwRetLen); End; Finally. CloseHandle(Token); End. Else. RaiseLastOSError; End; Procedure TForm1.FormCreate(Sender: TObject); Const. SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; Begin. FSystemShutdown := False; If not SetPrivilege(SE_SHUTDOWN_NAME, True) then. RaiseLastOSError; End; Procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession); Begin. Inherited; Message.Result := 0; AbortSystemShutdown(nil); FSystemShutdown := True; Close; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. ShowMessage('Bla...bla...bla!'); If FSystemShutdown then. InitiateSystemShutdown(nil, nil, 0, True, False); End; End.

Автор: Александр (Rouse_) Багель

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

©Drkb::01677.

Замена всех цветов на оттенки одного

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Замена всех цветов на оттенки одного. Зависимости: Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Procedure ModColors(Bitmap: TBitmap; Color: TColor); Function GetR(const Color: TColor): Byte; //извлечение красного. Begin. Result := Lo(Color); End; Function GetG(const Color: TColor): Byte; //извлечение зелёного. Begin. Result := Lo(Color shr 8); End; Function GetB(const Color: TColor): Byte; //извлечение синего. Begin. Result := Lo((Color shr 8) shr 8); End; Function BLimit(B: Integer): Byte; Begin. If B < 0 then. Result := 0. Else if B > 255 then. Result := 255. Else. Result := B; End; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. R1, g1, b1: Byte; X, y: Integer; Dest: pRGB; A: Double; Begin. Bitmap.PixelFormat := pf24Bit; R1 := Round(255 / 100 * GetR(Color)); G1 := Round(255 / 100 * GetG(Color)); B1 := Round(255 / 100 * GetB(Color)); For y := 0 to Bitmap.Height - 1 do. Begin. Dest := Bitmap.ScanLine[y]; For x := 0 to Bitmap.Width - 1 do. Begin. With Dest^ do. Begin. A := (r + b + g) / 300; With Dest^ do. Begin. R := BLimit(Round(r1 * A)); G := BLimit(Round(g1 * A)); B := BLimit(Round(b1 * A)); End; End; Inc(Dest); End; End; End; Пример использования: ModColors(FBitmap, RGB(218, 219, 230));

Замена подстрок

Автор: Сергей Шамайтис

Замена подстроки на другую.

Замена подстроки на другую

Code: Select Replace('Какая-то строка','Строка которую заменить','Строка на которую заменить').

©Drkb::02824.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Запретить использовать RegEdit.

Например мы вынесли компонент класса TCheckBox, назвали его "Использовать редактор системного реестра". Задача такова: когда флажок установлен пользователь может воспользоваться редактором реестра, когда не установлен - соответственно, не может!!!

Запретить Hint в TTreeView.

Запретить Hint в TTreeView.

Code: Const. TVS_NOTOOLTIPS = $80; Begin. With treeview1 do. SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE). Or TVS_NOTOOLTIPS); End;

©Drkb::00639.

Записать в реестр данные бинарного вида

Code: Var. Reg: TRegistry; Buf : array [0..4] of byte; I: Integer; Begin. Reg := TRegistry.Create; Try. Reg.RootKey := HKEY_CURRENT_USER; If Reg.OpenKey('\Software', True) then begin. For i:=1 to 4 do buf[i]:=0; Buf[0]:=1; Reg.WriteBinnaryData('Value', buf, sizeof(buf)); Reg.CloseKey; End; Finally. Reg.Free; Inherited; End; {...} End;

Записать содержимое окна OpenGL в BMP файл

Gr - объект, в канве которого я рисую с помощью OpenGL.

Запись сообщений в журнал событий Windows на Delphi.

Запись сообщений в журнал событий Windows на Delphi.

Автор: c "FMI Solutions" 2002 http://www.fmisolutions.com Перевод: © Digimaster 2005.

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

· RegisterEventSource - Открывает handle для доступа к журналу на локальной или удаленной машине.

· ReportEvent - Собственно записывает сообщение.

Для записи сообщений в журнал в упрощенной манере просто произведите вызов RegisterEventSource с именем машины (UNC), в журнал которой вы хотите поместить сообщение (nil для локальной машины), и именем события. Имя события это обычно имя приложения, но может быть чем-то более информативным. Как только источник событий зарегистрирован, можно записывать события при помощи ReportEvent с handle, который вернула RegisterEventSource.

Пример:

Code: VAR EventLog:THandle; EventLog:=RegisterEventSource(nil,PChar('MyApplication')); VAR MyMsg:Array[0..2] of PChar; MyMsg[0]:='A test event message'; ReportEvent(EventLog,EVENTLOG_INFORMATION_TYPE,0,0,nil,1,0,@MyMsg,nil);

Запись строки в реестр без использования класса TRegistry.

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Запись строки в реестр без использования класса TRegistry. Функция записывает в реестр информацию в виде строки. Входные параметры: RootKey - идентификатор корневого раздела реестра, например. HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE и т.д. Key - имя раздела реестра, если он не существует, то автоматически. Создаётся. Name - имя параметра, для записи параметра "По умолчанию" ("Default"), Эта строка должна быть пустой. Value - значение параметра. В случае успеха функция возвращает True, или False при возникновении. Ошибки записи в реестр. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 13 мая 2002 г. ***************************************************** } Function RegWriteStr(RootKey: HKEY; Key, Name, Value: string): Boolean; Var. Handle: HKEY; Res: LongInt; Begin. Result := False; Res := RegCreateKeyEx(RootKey, PChar(Key), 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, Handle, nil); If Res <> ERROR_SUCCESS then. Exit; Res := RegSetValueEx(Handle, PChar(Name), 0, REG_SZ, PChar(Value), Length(Value) + 1); Result := Res = ERROR_SUCCESS; RegCloseKey(Handle); End;

Cвой PGP на Delphi.

Cвой PGP на Delphi.

Сегодня нас ждет поистине Х-кодинг, а именно написание собственной крипто-проги, умеющей шифровать текст по принципу открытого ключа. Если ты уже напуган размерами исходников pgp (которые лень читать даже пробитым юниксоидам), я тебя успокою. Дело в том, что добрые капиталисты из tsm inc написали для нас совершенно бесплатный компонент, реализующий функции rsa алгоритма, который, собственно, сейчас и является стандартом асимметричного шифрования. Так что за размер кода можешь не беспокоиться, он будет неприлично маленьким и вместе с тем полноценным. Т.е. наша с тобой прога будет уметь все, как и ее старшие братья. А именно - генерить ключи, шифровать и расшифровывать. Прежде чем взяться за кодинг, нам придется припомнить пару теоретических моментов: 1) Шифрование информации производится при помощи public key, а расшифровка - private key. Первый может находиться у кого угодно (поскольку способен только шифровать), второй - только у того, кому пишут. Его надо беречь как девственность. Длина ключа может быть 512, 1024 и 2048 бит. В нашем примере я буду использовать 1024-битный ключ, поскольку меньшая длина уже давно считается отстоем, а 2048 слишком долго вычисляется моим компом. 2) Математической основой алгоритма являются 2 больших простых числа - p и q. Они настолько большие, что разработчики компонента (который мы сегодня будем использовать) ввели тип bignum. Подробнее я расскажу о нем ниже. Следовательно, автоматическая генерация ключа для нас будет заключаться именно в нахождении p и q. Остальное компонент сделает сам. И это правильно. Как говорил мой преподаватель труда, "пусть работают механизмы". Правда, он еще считал, что ананасы растут на деревьях, но рабочему человеку это простительно. Реквизит Срочно беги на http://www.crypto-central.com/software/freeware/rsa_free.zip и качай компонент. Если при появлении надписи "download complete" твои руки (как это обычно происходит со мной) приходят в сильное возбуждение и запускают инсталляцию загруженного, то уйми их. Потому что этого мало, надо еще зайти на http://www.crypto-central.com/cgi-bin/freeform.exe. Там, после заполнения простенькой формы (размер лифчика и годовой доход там не спрашивают, достаточно электронного адреса, имени и источника, откуда ты о них узнал) тебе на e-mail сваливается индивидуальный код для инсталляции. Можно, правда, ничего не заполнять, потому что я уже это сделал до тебя и получил вот что: hjkdl9l3s0s[39s3fm3. Это код для бесплатной версии. Ладно, теперь можно дать волю рукам и запустить инсталляцию - она сама найдет твой дельфи и положит в компоненты новую закладку - "crypto", содержащую компонент "rsa". Поэтому срочно кидай его на форму, и займемся программированием. Кодинг Нам понадобится следующее: 2 edit, 2 кнопки, 2 radiobutton (тоже лежит в закладке standard), 1 progressbar, 2 memo или richedit - кому что нравится. Переменные. Давай объявим следующее переменные:

Code: Pq, pp: bignum; Nado: boolean; I, length: integer; Fromt, tot: string;

Тут pq и pp - это p и q, о которых я говорил в начале, nado - определяет, надо ли создавать ключ, i и length - нужны для генерации ключа, fromt - исходная строка (для шифровки или расшифровки), tot - конечный текст. Ключики. С переменными все ясно, давай разберемся с генерацией ключа. Дело в том, что p и q, о которых я говорю уже в третий раз, в сущности представляют собой массивы из 32-битных чисел (следовательно, каждый элемент может принимать значение до $ffffffff), а длина самого массива будет зависеть от длины ключа и определяться переменной length. Поэтому все, что нам надо, это присвоить значение каждому элементу p и q, а затем вычислить ключи командой makekeypair. Можно, конечно, присвоить просто случайные значения, используя генератор псевдослучайных чисел от дельфи, как нас и учили в школе, но тут тебя может ждать облом. Числа, которые он выдает, очень предсказуемы, а потому делают наш ключ слишком уязвимым. Из-за этого, кстати, многие компоненты содержат свой генератор чисел, эффективность которых тоже вызывает сомнение. Потому мы и пойдем путем pgp - будем использовать координаты мышки (в случайности которых сомневаться не приходится) - т.е. для генерации ключа мы попросим юзера покрутить мышкой, вызывая таким образом событие mousemove, и будем использовать постоянно меняющиеся координаты как основу. Итак, начнем с соответствующей кнопки, которая называется "Сгенерировать ключ". Вот что представляет собой ее онклик:

Code: Nado:= true; i:=0; Length:= rsa1.getprecision; Progressbar1.min:=0; Progressbar1.max:=length-1;

Заполнение полей формы в TWebBrowser методом Drag-and-Drop.

Code: { This example shows how to fill out fields in your webbrowser by. Dragging the content of Label1 to a field of your webbrowser}. Procedure TForm1.FormCreate(Sender: TObject); Begin. Label1.DragMode := dmAutomatic; End; Procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Var. Item: Variant; Begin. //check if document is interactive. If (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then. Begin. Item := WebBrowser.OleObject.Document.elementFromPoint(x, y); If Source is TLabel then. Accept := True; Accept := (item.tagname = 'INPUT') and ((item.type = 'text') or. (item.type = 'password')) or (item.tagname = 'TEXTAREA'); End; End; Procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X, Y: Integer); Var. Item: Variant; Begin. //check if document is interactive. If (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then. Begin. Item := WebBrowser.OleObject.Document.elementFromPoint(x, y); Item.Value := label1.Caption; End; End;

Заполнение списка словами из строки

Запросы: Выбор Данных из Таблицы

Запросы: Выбор Данных из Таблицы.

Команда select (выбор) используется для извлечения данных из таблицы. Эту команду можно использовать для выбора данных как по строкам, так по столбцам из одной или нескольких таблиц.

В данной главе рассматриваются следующие темы:

· Выбор данных по всем столбцам таблицы.

· Выбор данных по указанным столбцам таблицы.

· Изменение формы представления результатов в операторе выбора путем переименования заголовков столбцов и добаления символьных строк.

· Включение простых вычисляемых величин в оператор выбора.

· Устранение одинаковых строк с помощью команды distinct (различные).

· Использование конструкции from (из) для указания таблиц и вьюверов (views).

· Использование в конструкции where (где) операций сравнения, логических операций, а также операций between (между), in (в), any (любой) и like (как).

· Использование значений null (неопределенный) и not null (определенный).

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

Что такое Запросы ?

Запрос это обращение к базе данных с целью получения результирующих данных. Этот процесс также называется нахождением данных. Все SQL запросы выражаются через оператор выбора (select). Этот оператор можно использовать как для выбора записей (строк) из одной или нескольких таблиц, так и для построения проекций (projections), т.е. выбора данных по некоторому подмножеству атрибутов (столбцов) из одной или нескольких таблиц.

В упрощенном виде оператор select можно записать следующим образом:

Code: Select список_выбора. From список_таблиц. Where условия_выбора.

Запрос пароля при инициализации приложения

Code: { Copyright © 1998 by Delphi 4 Developer's Guide - Xavier Pacheco and Steve Teixeira. } Program Initialize; Uses. Forms, Dialogs, Controls, MainFrm in 'MainFrm.pas' {MainForm}; {$R *.RES}. Var. Password: string; Begin. If InputQuery('Password', 'Enter your password', PassWord) then. If Password = 'D5DG' then. Begin. // Other initialization routines can go here. Application.CreateForm(TMainForm, MainForm); Application.Run; End. Else. MessageDlg('Incorrect Password, terminating program', mtError, [mbok], 0); End.

Запуск и закрытие Excel, добавление и удаление книг и листов

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Запуск и закрытие Excel, добавление и удаление книг и листов. На данный момент работает: - вызов и закрытие Excel. - добавление новых, открытие ранее созданных и удаление рабочих книг. - добавление и удаление листов в рабочие книги. Зависимости: ComObj, SysUtils,Dialogs,Controls; Автор: lookin, lookin@mail.ru, Екатеринбург. Copyright: lookin. Дата: 04 мая 2002 г. ********************************************** } Unit MSExcel; Interface. Uses ComObj, SysUtils,Dialogs,Controls; Procedure CallExcel(Show: boolean); Procedure CloseExcel; Procedure AddWorkBook(WorkBookName: Ansistring); Procedure OpenWorkBook(WorkBookName: Ansistring); Procedure CloseWorkBook(WorkBookName: Ansistring); Procedure ActivateWorkBook(WorkBookName: Ansistring); Procedure ActivateWorkSheet(WorkBookName,WorkSheetName: Ansistring); Function WorkBookIndex(WorkBookName: Ansistring): integer; Function WorkSheetIndex(WorkBookName,WorkSheetName: Ansistring): integer; Procedure CheckExtension(Name: Ansistring); Procedure AddWorkSheet(WorkBookName,WorkSheetName: Ansistring); Procedure DeleteWorkSheet(WorkBookName,WorkSheetName: Ansistring); Var Excel: Variant; Implementation. Procedure CallExcel(Show: boolean); Begin. If VarIsEmpty(Excel)=true then begin. Excel:=CreateOleObject('Excel.Application'); If Show then Excel.Visible:=true; end; End; Procedure CloseExcel; Begin. If VarIsEmpty(Excel)=false then begin. Excel.Quit; Excel:=0; end; End; Procedure AddWorkBook(WorkBookName: Ansistring); Var k: integer; Begin. CheckExtension(WorkBookName); If VarIsEmpty(Excel)=true then begin. Excel:=CreateOleObject('Excel.Application'); Excel.Visible:=true; end; K:=WorkBookIndex(WorkBookName); If k=0 then begin Excel.Workbooks.Add; Excel.ActiveWorkbook.SaveCopyAs(FileName:=WorkBookName); Excel.ActiveWorkbook.Close; Excel.Workbooks.Open(WorkBookName); end else. MessageDlg('Книга с таким именем уже существует.',mtWarning,[mbOk],0); End; Procedure OpenWorkBook(WorkBookName: Ansistring); Var k: integer; Begin. CheckExtension(WorkBookName); If VarIsEmpty(Excel)=true then begin. Excel:=CreateOleObject('Excel.Application'); Excel.Visible:=true; end; K:=WorkBookIndex(WorkBookName); If k=0 then Excel.Workbooks.Open(WorkBookName) else. MessageDlg('Книга с таким именем уже открыта.',mtWarning,[mbOk],0); End; Procedure CloseWorkBook(WorkBookName: Ansistring); Var k: integer; Begin. If VarIsEmpty(Excel)=false then begin. K:=WorkBookIndex(WorkBookName); If k<>0 then Excel.ActiveWorkbook.Close(WorkBookName) else. MessageDlg('Книга с таким именем отсутствует.',mtWarning,[mbOk],0); end; End; Procedure ActivateWorkBook(WorkBookName: Ansistring); Var k: integer; Begin. If VarIsEmpty(Excel)=false then begin. K:=WorkBookIndex(WorkBookName); If k<>0 then Excel.WorkBooks[k].Activate; end; End; Procedure ActivateWorkSheet(WorkBookName,WorkSheetName: Ansistring); Var k,j: integer; Begin. If VarIsEmpty(Excel)=false then begin. K:=WorkBookIndex(WorkBookName); J:=WorkSheetIndex(WorkBookName,WorkSheetName); If j<>0 then Excel.WorkBooks[k].Sheets[j].Activate; end; End; Procedure AddWorkSheet(WorkBookName,WorkSheetName: Ansistring); Var k,j: integer; Begin. If VarIsEmpty(Excel)=false then begin. K:=WorkBookIndex(WorkBookName); If k<>0 then begin Excel.DisplayAlerts:=False; Excel.Workbooks[k].Sheets.Add; J:=WorkSheetIndex(WorkBookName,WorkSheetName); If j=0 then Excel.Workbooks[k].ActiveSheet.Name:=WorkSheetName; End; end; End; Procedure DeleteWorkSheet(WorkBookName,WorkSheetName: Ansistring); Var k,j: integer; Begin. If VarIsEmpty(Excel)=false then begin k:=WorkBookIndex(WorkBookName); Excel.DisplayAlerts:=false; J:=WorkSheetIndex(WorkBookName,WorkSheetName); If j<>0 then Excel.Workbooks[k].Sheets[j].Delete else. MessageDlg('Листа с таким именем в этой книге нет.',mtWarning,[mbOk],0); end; End; Procedure CheckExtension(Name: Ansistring); Var s: string; Begin. //проверка расширения. S:=ExtractFileExt(Name); If LowerCase(s)<>'.xls' then. If MessageDlg('Вы задали имя книги с нестандартным расширением. Продолжить?', MtWarning,[mbYes,mbCancel],0)=mrCancel then Abort; End; Function WorkBookIndex(WorkBookName: Ansistring): integer; Var i,n: integer; Begin. //проверка на наличие книги с этим именем. N:=0; If VarIsEmpty(Excel)=false then for i:=1 to Excel.WorkBooks.Count do. If Excel.WorkBooks[i].FullName=WorkBookName then begin n:=i; break; end; WorkBookIndex:=n; End; Function WorkSheetIndex(WorkBookName,WorkSheetName: Ansistring): integer; Var i,k,n: integer; Begin. //проверка на наличие листа с этим именем в книге с этим именем. N:=0; If VarIsEmpty(Excel)=false then begin k:=WorkBookIndex(WorkBookName); For i:=1 to Excel.WorkBooks[k].Sheets.Count do. If Excel.WorkBooks[k].Sheets[i].Name=WorkSheetName then begin. N:=i; break; end; end; WorkSheetIndex:=n; End; End.

Запустить приложение с помощью ShellExecute и подождать.

Запустить приложение с помощью ShellExecute и подождать

Code: Var. ExInfo: TShellExecuteInfo; Begin. FillChar( exInfo, Sizeof(exInfo), 0 ); With exInfo Do Begin. CbSize:= Sizeof( exInfo ); // required! FMask := SEE_MASK_NOCLOSEPROCESS; Wnd := Handle; // forms handle. LpVerb:= 'paintto'; LpFile:= Pchar( pdffilename ); LpParameters := PChar( printernameAndPort ); NShow := SW_HIDE; End; If ShellExecuteEx( @exInfo ) Then Begin. While GetExitCodeProcess( exinfo.hProcess, exitcode ). And (exitcode = STILL_ACTIVE). Do. Sleep( 500 ); CloseHandle( exinfo.hProcess ); DeleteFile( pdffilename ); End. Else. ShowMessage(SysErrorMessage( GetLastError ));

©Drkb::02151.

Запущен ли сервер удаленного доступа (RAS).

Запущен ли сервер удаленного доступа (RAS).

Code: Function checkras: boolean; Const maxentries = 100; Var. Bufsize : integer; Numentries: integer; Entries : array[1..maxentries] of trasconn; Begin. Entries[1].dwsize := sizeof(trasconn); Bufsize:=sizeof(trasconn)*maxentries; Fillchar(stat, sizeof(trasconnstatus), 0); Rasenumconnections(@entries[1], bufsize, numentries); If numentries > 0 then result:=true. Else result:=false; End;

Заставить мерцать индикаторы клавиш CapsLock, NumLock и ScrollLock.

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

Захват части изображения

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

Сase для строки

Защита приложений от крупных шрифтов.

Защита приложений от крупных шрифтов

Защита приложений от крупных шрифтов.

Вы когда-нибудь проверяли как будет выглядеть написанная вами с такой любовью программа с системе с крупными шрифтами? Согласитесь, это неприглядное зрелище. Наползающие друг на друга метки и поля редактирования, надписи, которые заканчиваются где то за пределами формы и т.п. После этого появляется неконтролируемая неприязнь к пользователям, которые предпочитают режим крупных шрифтов. Но это их право. И ваша проблема. Вы наверняка задавались вопросом о том, как избежать искажений. И находили в сети одни и те же рецепты: использовать шрифты TrueType и отключать свойство Scaled у форм. Рецепт, предлагающий использовать только шрифты TrueType + Scaled = False для форм - верен. Однако тут есть некоторые неудобства. Дело в том, что ни один из стандартных TrueType шрифтов не сравнится по качеству отображения с MS Sans Serif, который по умолчанию используется в вашем приложении. Самый близкий - Arial все же имеет довольно заметные отличия и проигрывает MS Sans Serif по читаемости. Искажений форм так же полностью избежать не удастся. Особенно это может повлиять на компоновку сложных форм, а также при использовании в интерфейсе изображений и прочих немасштабируемых элементов. Иногда хочется просто запретить масштабирование и защитить программу от влияния крупных шрифтов. Но использовать MS Sans Serif в этом случае нельзя, так как в режиме крупных шрифтов система "сдвигает" их на 2 пункта вверх и шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах.

для справки В режиме стандартных размеров шрифтов в качестве системного используется, в основном, MS Sans Serif - рубленый шрифт без засечек. Он имеет размеры 8pt, 10pt, 12pt, 14pt, 18pt и 24pt. В основном используется размер 8pt. В режиме крупных шрифтов система увеличивает все шрифты на 120%. ( С 96 pixels per inch до 120 pixels per inch). Шрифт MS Sans Serif имеет всего 6 размеров. Поэтому 8pt становится 10pt, 10pt - 12pt и т.д. Шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах. Шрифты же TrueType могут имеют произвольные размеры и шаг изменения равен 1pt. Поэтому при крупных шрифтах размеры TrueType и не-TrueType шрифтов изменяются по разному

Предлагаемое решение способно защитить программу от влияния режима крупных шрифтов и не отказываться от шрифта MS Sans Serif при разработке программы. Подход состоит в том, чтобы заменять все шрифты MS Sans Serif на Arial при запуске программы при крупных шрифтах. Создавать программу, естественно, следует при мелких шрифтах. Можно написать невизуальный компонент и добавить его на каждую форму. Компонент при загрузке проверяет режим и при обнаружении режима "Big Fonts" "обходит" все визуальные компоненты для замены шрифта. Также компонент заботится о том, чтобы свойство Scaled у форм было отключено.

Code: Unit glSmallFontsDefence; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Type. TglSmallFontsDefence = class(TComponent). Private. Procedure UpdateFonts(Control: TWinControl); { Private declarations }. Protected. Procedure Loaded; override; Public. Constructor Create(AOwner: TComponent); override; Published. { Published declarations }. End; Procedure Register; Implementation. Function IsSmallFonts: boolean;{Значение функции TRUE если мелкий шрифт}. Var DC: HDC; Begin. DC:=GetDC(0); Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96); { В случае крупного шрифта будет 120}. ReleaseDC(0, DC); End; Procedure Register; Begin. RegisterComponents('Gl Components', [TglSmallFontsDefence]); End; { TglSmallFontsDefence }. Constructor TglSmallFontsDefence.Create(AOwner: TComponent); Begin. Inherited; If (Owner is TForm) then (Owner as TForm).Scaled := false; End; Procedure TglSmallFontsDefence.Loaded; Begin. Inherited; If (Owner is TForm) then (Owner as TForm).Scaled := false; If csDesigning in ComponentState then. Begin. If not IsSmallFonts then. ShowMessage('Проектирование приложения в режиме крупных' + ' шрифтов недопустимо!'#13#10+ 'Компонент TglSmallFontsDefence отказывается' + ' работать в таких условиях.'); End else. UpdateFonts((Owner as TForm)); End; Procedure TglSmallFontsDefence.UpdateFonts(Control: TWinControl); Var. I: integer; Procedure UpdateFont(Font: TFont); Begin. If CompareText(Font.Name, 'MS Sans Serif') <> 0 then exit; Font.Name := 'Arial'; End; Begin. If IsSmallFonts then exit; UpdateFont(TShowFont(Control).Font); With Control do. For i:=0 to ControlCount-1 do. Begin. UpdateFont(TShowFont(Controls[i]).Font); If Controls[i] is TWinControl then UpdateFonts(Controls[i] as TWinControl); End; End; End.

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

составление статьи: Андрей Чудин, ЦПР ТД Библио-Глобус.

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

©Drkb::01932.

Защита программы паролем

Защита программы паролем Как видно из примера, программист может поместить любой код до обращения к методу application.run. В частности, он может показать диалоговое окно с запросом пароля и блокировать вызов application.run, если введенный пользователем пароль неверен. В следующем примере (листинг 4 — password.dpr) в проекте используются две формы: стандартная форма inputquery и главная форма mainform. Форма inputquery создается при обращении к одноименной функции, определенной в модуле dialogs. Она представляет собой небольшое диалоговое окно с однострочным редактором tedit и двумя кнопками — ОК и cancel. В окне пользователь должен ввести пароль (delphi) и нажать enter.

Листинг 4.

Code: Program password; Uses. Forms, Dialogs, // В этом модуле определена функция inputquery. Unit1 in 'unit1.pas' {mainform}; {$r *.res}. Var. Passwrd: string; Begin. // Запрашиваем пароль: If inputquery('Окно ввода пароля','Введите пароль:',passwrd) then. // Проверяем его: If passwrd = 'delphi' then. Begin // Все в порядке, пароль верен. Application.createform(tmainform, mainform); Application.run; End else. Showmessage('Пароль не верен!'); End.

Защита от копирования с CD.

Code: Procedure craye_file_inc; Var j : int64; Buf : array[word] of byte; St : TFileStream; Begin. For j:=0 to 32766 do. Buf[j]:=byte(j); // ne pas craye un fichier de moins de 32k. St:=Tfilestream.create('Protection.dat',fmCreate); For j:=0 to 10 do. St.write(Buf,Sizeof(Buf)); St.free; End;

Code: // dans votre programme. Function CheckIfOriginalCd:Boolean. Var f : thandle; B : array[0..500] of byte; Lus : integer; Totlus : Int64; Begin. Result:=false; Totlus:=0; If not fileexist('Protection.dat') then exit; F:=Filecreate('Protection.dat',fmRead); While true do. Begin. Try. Fileread(f,b,lus); Exept. Break; End; Totlus:=totlus+lus; If lus=0 then. Break; End; If filesize('Protection.dat')<>Totlus then. If attributs, time etc etc... then. Result:=true; End;

За какое время было создано изображение

Автор: Даниил Карапетян

WEB сайт: http://program.dax.ru.

CD Remember.

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

Исходный код модуля:

Code: Unit cd; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, StdCtrls, MMSystem; Type. TForm1 = class(TForm). Label1: TLabel; Button1: TButton; Label2: TLabel; Label3: TLabel; BitBtn1: TBitBtn; BitBtn2: TBitBtn; Edit1: TEdit; GroupBox1: TGroupBox; RadioButton1: TRadioButton; RadioButton2: TRadioButton; Button2: TButton; Procedure FormCreate(Sender: TObject); Procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); Procedure BitBtn2Click(Sender: TObject); Procedure BitBtn1Click(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Function FindCD:Integer; Var. I, DType:integer; Str:string; Drive:integer; Begin. Result:=0; For i:=65 to 90 do. Begin. Str:=chr(i)+':\'; DType:=GetDrivetype(PChar(str)); Case DType of. 0: drive:=0; 1: drive:=1; DRIVE_CDROM : drive:=i; End; If not ((DType=0) or (Dtype=1)) then. Result:=drive; End; End; Function DiskInDrive(Drive: Char): Boolean; Var. ErrorMode: word; Begin. { переводим в верхний регистр }. If Drive in ['a'..'z'] then Dec(Drive, $20); { убеждаемся, что это буква }. If not (Drive in ['A'..'Z']) then. Raise EConvertError.Create('Not a valid drive ID'); //отключаем критические ошибки// ErrorMode := SetErrorMode(SEM_FailCriticalErrors); Try. If DiskSize (Ord(Drive) - $40) = -1 then. Result := False. Else. Result := True; Finally. { восстанавливаем старый режим ошибок }. SetErrorMode(ErrorMode); End; End; Procedure ChooseCloseMode; Begin. Form1.Height:=290; Form1.Repaint; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Edit1.text:=(chr(Findcd)+':\'); Button1.Enabled:=false; Label1.Enabled:=false; End; Procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); Begin. If DiskInDrive(chr(findcd))=true then. Begin. Canclose:=false; Form1.Show; End. Else // если нет. CanClose:=true; End; Procedure TForm1.BitBtn2Click(Sender: TObject); Begin. ChooseCloseMode; End; Procedure TForm1.BitBtn1Click(Sender: TObject); Begin. MciSendString('Set cdaudio door open wait', nil, 0, handle); Button1.Enabled:=true; Label1.Enabled:=true; BitBtn1.Enabled:=false; Bitbtn2.Enabled:=false; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. MciSendString('Set cdaudio door closed wait', nil, 0, handle); ChooseCloseMode; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. If Radiobutton1.Checked=true then. ExitWindowsEx(EWX_POWEROFF or EWX_SHUTDOWN,0). Else. If Radiobutton2.Checked=true then. ExitWindowsEx(EWX_REBOOT,0); End; End.

Немного кривоваты комментарии, но кому нужно - разберется.

Код .DPR файла:

Code: Program cdrem; Uses. Forms, Cd in 'cd.pas' {Form1}; {$R *.RES}. Begin. Application.Initialize; Application.ShowMainForm:=false; Application.CreateForm(TForm1, Form1); Application.Run; End.

Автор: Blabsadm.

Компилятор: Delphi 5.

©Drkb::01405.

CGI.

Аббревиатура CGI означает Common Gateway Interface, и является связевым протоколом между формой в Web браузере (клиент) и приложением запущенным на Web сервере (сервер). Приложение обычно называется CGI скрипт, но мы можем использовать Дельфи для написания CGI приложений без скриптов.

Имеется два типа CGI: стандартное или консольное CGI приложение и позже появилась версия для Windows называемая WinCGI.

1.3.1. Консольное CGI приложение.

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

1.3.2. WinCGI.

Приложение WinCGI взаимодействует с формой на клиенте с помощью Windows .INI файла вместо переменных среды. Windows .INI файл содержит управляющую информацию, иногда данные формы и имена входного, данных и выходного файлов.

1.3.3. Delphi и CGI.

В данной главе я расскажу, как написать простое Дельфи CGI приложение, без использования Web Modules или других Client/Server модулей.

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

На сервере запускается CGI приложение, которое иногда называется CGI скрипт (для примера на Unix машинах, где Perl используется для исполнения CGI скриптов).

В данной главе я сконцентрирую внимание на написание CGI приложения для Windows NT web сервера, и использовании 32-битной Дельфи (например Delphi 2.x или 3.x) для данной задачи, данный код может быть также без проблем откомпилирован в C++Builder.

Стандартное CGI приложение получает данные через стандартный вход и должно выдать ответ через стандартный вывод. (например сгенерированную HTML страницу). Это означает необходимость написания консольного приложения. Если даже нет входных данных мы все равно можем использовать CGI приложение для генерации динамических HTML страниц (например для выдачи данных их таблицы).

1.3.4. Динамический вывод.

Для начала посмотрим на стандартное "hello world" CGI приложение. Единственное, что оно должно сделать, это вернуть HTML страницу со строкой "hello, world". Перед тем как мы начнем делать это - обратим внимание на следующее: CGI приложение должно сообщить миру какой (MIME) формат оно выдает. В нашем случае это "text/html", которое мы должны указать как: content-type: text/html, и затем одну пустую строку.

Вот код нашего первого "Hello, world!" CGI приложения:

Code: Program CGI1; {$APPTYPE CONSOLE}. Begin. Writeln('content-type: text/html'); Writeln; Writeln('<HTML'); Writeln('<BODY'); Writeln('Hello, world!'); Writeln('</BODY'); Writeln('</HTML'). End.

CheckBox в StringGrid.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls; Type. TForm1 = class(TForm). StringGrid1: TStringGrid; Procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Const. Cell_x = 2; Cell_y = 2; Var. Form1: TForm1; CheckBox1: TCheckBox; Implementation. {$R *.DFM}. Procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Var. R:trect; Begin. If(cell_x>=StringGrid1.LeftCol) and. (cell_x<=StringGrid1.LeftCol+StringGrid1.VisibleColCount) and. (cell_y>=StringGrid1.TopRow) and. (cell_x<=StringGrid1.TopRow+StringGrid1.VisibleRowCount) then. CheckBox1.Visible:=true. Else. CheckBox1.Visible:=false; If (acol=cell_x) and (arow=cell_y) then. Begin. R:=stringgrid1.CellRect(cell_x,cell_y); R.Left:=r.left+stringgrid1.left+2; R.right:=r.right+stringgrid1.left+2; R.top:=r.top+stringgrid1.top+2; R.bottom:=r.bottom+stringgrid1.top+2; CheckBox1.BoundsRect:=r; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. CheckBox1:=TCheckBox.Create(form1); CheckBox1.parent:=form1; CheckBox1.Caption:='proba'; End; End.

Cоздание документа MS Word.

Труд программиста оценивается только пользователями и почти всегда по конечному результату. Используя материалы первой и второй частей статьи "Суперфункции", мы уже имеем возможность предоставить пользователю свою программу формирования простого документа в редакторе Word в законченном виде.

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

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

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

Определим функцию открытия ранее созданного документа OpenDoc. Для этого используем метод Open коллекции Documents, которая нами уже использовалась в функции создания нового документа. Функция Open, кроме обязательного аргумента (имени файла), может иметь ряд дополнительных аргументов, которые определяют режим открытия. Она возвращает ссылку на объект типа Document, но в нашем случае будем использовать только обязательный аргумент.

Code: Function OpenDoc (file_:string):boolean; Var Doc_:variant; Begin. OpenDoc:=true; Try. Doc_:=W.Documents; Doc_.Open(file_); Except. OpenDoc:=false; End; End;

Создание приложений для ORACLE с помощью Delphi Client-Server.

Cоздание приложений для ORACLE с помощью Delphi Client-Server.

Автор: Наталия Елманова, Центр Информационных Технологий

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

· иметь меню, похожее на стандартное, с разделами "Файл", "Редактирование", "Сервис", "Справка" (или похожее), при этом пункты меню должны иметь соответствующие "горячие" клавиши клавиши быстрого доступа;

· иметь инструментальную панель , содержащую кнопки, дублирующие наиболее часто используемые пункты меню;

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

· использовать праую клавишу мыши для вызова контекстно-зависимых меню;

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

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

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

Современные средства быстрой разработки Windows-приложений, или так называемые RAD-средства (RAD расшифровывается как Rapid Application Development) обладают в той или иной степени почти всеми возможностями создания в приложениях подобных интерфейсных элементов. Многие из них позволяют осуществлять доступ с базам данных, в том числе и к серверным БД. Однако Borland Delphi (как версия 1.0, так и версия 2.0), на взгляд автора, является в этом отношении наиболее наиболее простым и удобным в использовании средством.

Причины этого заключаются в следующем:

· создание пользовательского интерфейса происходит практически без написания кода;

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

· легко создаются контекстно-зависимая справка, ярлычки с подсказками, панели состояний, инструментальные панели;

· имеется большая библиотека шаблонов форм и приложений, которую можно пополнять своими шаблонами;

· доступ к данным, будь то плоские таблицы или серверные БД типа ORACLE, совершенно однотипен, а описание конкретных источников данных можно вынести за пределы приложения в специальный файл конфигурации бибилиотеки BDE, обеспечивающей универсальную работу с разнородными данными, вплоть до гетерогенных запросов (это могут сделать далеко не все RAD-средства);

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

· приложения отличаются высокой производительностью, так как они являются полностью скомпилированными выполняемыми модулями (а большинство используемых RAD-средств использует интерпретируемый код), а, кроме того, язык программирования Object Pascal, используемый в Delphi, отличается жесткой типизацией переменных, что также положительно сказывается на производительности;

· отладка приложений очень удобна за счет того, что, во-первых , компилятор Pascal является очень быстрым, во-вторых, поддерживается инкрементная компиляция, в-третьих, в среду разработки встроен удобный и гибкий отладчик;

· средства работы с графикой так же удобны, как и в Pascal (для средств разработки приложений, работающих с БД, это большая редкость);

· поддерживаются элементы VBX (в первой версии) и OCX (во второй версии); на сегодняшний день на рынке имеется также большое количество дополнительных компонент для Delphi, созданных на самой Delphi, и их создание является несложным процессом;

· имеется интерфейс со средством контроля версий Intersolv PVCS, облегчающий групповую разработку крупных проектов;

· имеются удобные средства генерации отчетов, при этом можно использовать и генераторы отчетов сторонних разработчиков (например, Crystal Reports);

· среда разработки создана с учетом последних достижений в области эргономики - никаких лишних движений мышью, или лишних нажатий на клавиши (рис.1).

Как создаются приложения на Delphi? Это очень просто. Вы создаете новый проект (или используете готовый шаблон), помещаете на форму интерфейсные элементы, компоненты для доступа к данным, связываете все это между собой в инспекторе объектов, если нужно, дописываете обработчики событий (это может и не потребоваться) - и приложение готово! (рис.2).

Что интересного может предложть Delphi для разработчиков информационных систем на базе ORACLE? Во-первых, высокопроизводительный драйвер этой СУБД (хотя, конечно, никто не запретит Вам пользоваться ODBC, который, естественно, поддерживается Delphi). Во-вторых, Ваши приложения будут добросовестно цитировать все высказвания созданных на сервере триггеров, если таковые будут срабатывать во время работы приложения. В-третьих, если Вы используете версию 2.0 - в Вашем распряжении репозиторий, включающий словарь данных, навигатор баз данных, SQL-монитор, поддержка хранимых процедур и сессий, модули данных, огромное разнообразие интерфейсных элементов, в том числе и похожих на те, что есть в Oracle Power Objects, а также неограниченные возможности наращивания функциональности среды разработки за счет дополнительных эспертов, редакторов свойств и компонент. В-четвертых, Вы можете легко интегрировать в среду разработки продукты третьих фирм, например, для интерфейса с CASE-средствами (один из таких продуктов, CASE Expert - средство для экспорта ER-диаграммы в словарь данных Delphi, входит в поставку Delphi 2.01). Отметим также, что Delphi 2.0 поддерживает многопоточность, OLE-automation и другие механизмы и технологии 32-разрядных операционных систем Windows. В Delphi 2.0 имеются эффктивные механизмы обработки транзакций с использванием механизмов кэшированного обновления данных, поддерживается ряд расширений SQL, имеется Data Pump Expert для переноса данных между серверами и масштабирования приложений. В обеих версиях Delphi Client/Server имеется визуальный конструктор запросов, позволяющий сгенерировать многотабличный запрос на языке SQL, в том числе с вычисляемыми полями (интерфейс и рабочий экран этого конструктора напоминает по внешнему виду некоторые популярные CASE-средства).

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

На мой взгляд, у Delphi есть один крупный недостаток - созданные приложения не являются многоплатформенными и могут эксплуатироваться только в Windows 95 и NT в случае версии Delphi 2.0, а также дополнительно в Windows 3.1 и 3.11 в случае версии Delphi 1.0 . Но и этот недостаток можно преодолеть путем использования технологии Intranet в корпоративных системах, когда приложение, созданное на Delphi, запускается Web-сервером, а полученные формы отображаются в Web-броузере на компьютере пользователя, где может быть использована любая другая операционная система, отличная от Windows.

Таким образом, Delphi Client/Server 1.0 и Delphi Client/Server Suite 2.0 являются очень удобными инструментами для создания клиентских приложений, использующих серверы ORACLE. Об этом свидетельствует высокая популярность этого средства среди разработчиков программ. Если Вы выбрали это средство - Вы всегда найдете друзей и единомышленников, готовых помочь Вам в случае появления каких-либо проблем, в том числе и в фирме "Интерфейс", имеющей авторизованный учебный центр Borland и консультационную службу.

©Drkb::02738.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

CMYK --> RGB.

Code: Procedure CMYKTORGB(C : byte; M: byte; Y : byte; K : byte; Var R : byte; Var G : byte; Var B : byte); Begin. If (Integer(C) + Integer(K)) 255 then MinColor := 255 - K; C := C - MinColor; M := M - MinColor; Y := Y - MinColor; K := K + MinColor; End;

Как определить, работает ли программа в виртуальной машине Connectrix?

Code: { This function can be used to determine whether your program is. Running from within Connectrix's Virtual PC. } Function running_inside_vpc: boolean; assembler; Asm. Push ebp. Mov ecx, offset @@exception_handler. Mov ebp, esp. Push ebx. Push ecx. Push dword ptr fs:[0]. Mov dword ptr fs:[0], esp. Mov ebx, 0 // flag. Mov eax, 1 // VPC function number. // call VPC. Db 00Fh, 03Fh, 007h, 00Bh. Mov eax, dword ptr ss:[esp]. Mov dword ptr fs:[0], eax. Add esp, 8. Test ebx, ebx. Setz al. Lea esp, dword ptr ss:[ebp-4]. Mov ebx, dword ptr ss:[esp]. Mov ebp, dword ptr ss:[esp+4]. Add esp, 8. Jmp @@ret. @@exception_handler: Mov ecx, [esp+0Ch]. Mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running. Add dword ptr [ecx+0B8h], 4 // -> skip past the detection code. Xor eax, eax // exception is handled. Ret. @@ret: End;

Converting 16bit resource to 32bit.

If you have the original source file (.rc) then you can simply recompile the .rc file to a .res file using the Borland Resource Command Line Compiler (brcc32.exe) located in the Delphi/C++ Builders bin directory. If you only have a .res file to work with, you will need to use a quality resource compiler/decompiler such as Borland's Resource Workshop. Versions of the Borland's Resource Workshop later than 4.5 can extract, compile, and decompile both 16 and 32 bit resource files from a variety of sources including .res, .exe, .dll, drv, and .cpl files. The Borland Resource Workshop version 4.5 ship with the Borland RAD Pack product line.

©Drkb::02160.

CopyFile для Linux.

Code: Function CopyFile(Org, Dest:string):boolean; Var Source, Target:TFileStream; Begin. Result:=false; Try. Try. Source:=TFileStream.Create(Org, fmShareDenyNone or fmOpenRead); Try. Target:=TFileStream.Create(Dest, fmOpenWrite or fmCreate); Target.CopyFrom(Source,Source.Size); Result:=true; Finally. Target.Free; End; Finally. Source.Free; End; Except. End; End;

CORBA клиент-сервер

Code: Unit ufrmCorbaClient; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SimpleCorbaServer_TLB, corbaObj, Grids; Type. TForm1 = class(TForm). GroupBox1: TGroupBox; Label2: TLabel; EdtDatabase: TEdit; Label3: TLabel; EdtUserName: TEdit; Label4: TLabel; EdtPassword: TEdit; Button5: TButton; GroupBox2: TGroupBox; MemoSQL: TMemo; GroupBox3: TGroupBox; Button6: TButton; GrdCorbaData: TStringGrid; Procedure ConnectClick(Sender: TObject); Procedure ExecuteClick(Sender: TObject); Private. { Private declarations }. FQueryServer: IQueryServer; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.ConnectClick(Sender: TObject); Begin. If not (assigned(FQueryServer)) then. FQueryServer := TQueryServerCorbaFactory.CreateInstance('SimpleServer'); FQueryServer.Login(edtDatabase.Text, edtUserName.Text, edtPassword.Text); End; Procedure TForm1.ExecuteClick(Sender: TObject); Var. I, j: integer; CorbaData: OLEVariant; Begin. FQueryServer.SQL := memoSQL.Text; FQueryServer.Execute; GrdCorbaData.ColCount := FQueryServer.FieldCount; GrdCorbaData.RowCount := 0; J := 0; While not (FQueryServer.EOF) do. Begin. Inc(j); GrdCorbaData.RowCount := j; CorbaData := (FQueryServer.Data); For i := 0 to FQueryServer.FieldCount - 1 do. Begin. GrdCorbaData.Cells[i + 1, j - 1] := CorbaData[i]; End; FQueryServer.Next; End; End; End.

CORBA клиент – Java Server.

Code: Unit uDelphiClient; Interface. Uses. Windows, Messages, SysUtils, CorbInit, CorbaObj, orbpas, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. ISimpleText = interface. ['{49F25940-3C3C-11D3-9703-0000861F6726}']. Function SetText(const txt: string): string; End; TSimpleTextStub = class(TCorbaStub, ISimpleText). Public. Function SetText(const txt: string): string; End; TForm1 = class(TForm). EdtDelphiText: TEdit; BtnDelphiTextLate: TButton; BtnDelphiTextEarlyClick: TButton; EdtResult: TEdit; Procedure btnDelphiTextLateClick(Sender: TObject); Procedure btnDelphiTextEarlyClickClick(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.btnDelphiTextLateClick(Sender: TObject); Var. JavaServer: TAny; Begin. JavaServer := ORB.Bind('IDL:CorbaServer/SimpleText:1.0'); EdtResult.Text := JavaServer.setText(edtDelphiText.text); End; { TSimpleTextStub }. Function TSimpleTextStub.SetText(const txt: string): string; Var. InBuf: IMarshalInBuffer; OutBuf: IMarshalOutBuffer; Begin. FStub.CreateRequest('setText', True, OutBuf); OutBuf.PutText(pchar(txt)); FStub.Invoke(OutBuf, InBuf); Result := UnmarshalText(InBuf); End; Procedure TForm1.btnDelphiTextEarlyClickClick(Sender: TObject); Var. JavaServer: ISimpleText; Begin. JavaServer := CorbaBind(ISimpleText) as ISimpleText; EdtResult.Text := JavaServer.SetText(edtDelphiText.text); End; Initialization. CorbaStubManager.RegisterStub(ISimpleText, TSimpleTextStub); CorbaInterfaceIDManager.RegisterInterface(ISimpleText, 'IDL:CorbaServer/SimpleText:1.0'); End.

CORBA - Архитектура распределенных объектов.

CORBA - Архитектура распределенных объектов

Сервер компании Epsylon Technologies.

Обзор архитектуры CORBA.

Обобщенная Архитектура построения Брокеров Объектных Запросов разработана для поддержки интеграции самых разнообразных объектных систем. Спецификация CORBA устанавливает принципы создания Брокеров Объектных Запросов, которые и допускают такую интеграцию.

Запрос посылается от клиента к серверу. Клиент это приложение, или нечто другое, выполняющее операцию над объектом, а реализация объекта - это код и данные, которые на самом деле выполняют эту операцию. ORB способен выполнить все действия, необходимые для нахождения реализация указанного объекта, подготовке этой реализации к обработке запроса и передаче данных, относящихся к запросу. Интерфейс, предоставляемый клиенту абсолютно не зависит от местоположения реализации объекта, языка программирования, на котором он написан или каких-либо других аспектов, не влияющих на определение интерфейса для данного объекта. Брокер Объектных Запросов.

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

· Операции, которые одинаковы для всех реализаций ORB-а.

· Операции, специфичные для конкретного объектного типа.

· Операции, специфичные для отдельных видов реализаций объектов.

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

Ядро Брокера Объектных Запросов обеспечивает основные механизмы для манипуляций объектами и выполнения запросов. Спецификация CORBA предназначается для поддержки различных механизмов реализации объектов, поэтому структура ядра не определяется. Вместо этого задается набор интерфейсных функций, которые должны присутствовать в каждой реализации ORB-а и тем самым маскируют отличия между различными реализациями Брокеров Объектных Запросов. Объекты.

Система объектов обеспечивает клиента набором сервисов. Клиент способен запросить некоторый сервис. Объект - это нечто, что обеспечивает один или более сервисов, которые клиент может запросить. Пример Брокеров Объектных Запросов.

Доступно широкое множество способов реализации конкретных ORB-ов. Далее будут приведены примеры таких реализаций. Следует иметь ввиду, что конкретный ORB может быть реализован сразу несколькими способами. ORB, включаемый в клиентское и серверное приложение.

Если имеется подходящий механизм коммуникаций, то возможна реализация ORB-а в виде набора подпрограмм как со стороны клиента, так и со стороны реализации объекта. Вызовы методов могут транслироваться в работу со средствами взаимодействия процессов (Inter Process Communication - IPC). ORB, выполненный в виде сервера.

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

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

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

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

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

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

Сервисы, которые обеспечиваются ORB-ом посредством адаптеров объектов часто включают: генерацию и интерпретацию ссылок на объекты, вызов методов, активацию и деактивацию реализаций объектов, а также регистрацию конкретных реализаций и отображение объектных ссылок и реализаций.

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

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

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

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

Клиент запрашивает сервисы инициированием запросов. Запрос - это событие, то есть действие, происходящее в конкретный момент. С запросом связана информация, состоящая из операции, объекта, у которого запрашивается сервис, нуля или более действительных параметров вызова и необязательный контекст запроса. Форма запроса - это описание или шаблон, который может быть выполнен произвольное количество раз. Форма запроса определяется отображением для конкретного языка программирования. Альтернативной формой запроса является использования Интерфейса Динамических Вызовов, который позволяет создать запрос, добавить аргументы и выполнить запрос. Под значением понимается допустимый параметр запроса. Значение которое определяет объект, называется ссылкой на объект, связанной с конкретным экземпляром объекта. Выполнение запроса вызывает выполнение соответствующего сервиса. После завершения запроса клиенту возвращается результат запроса (если он есть). В случае ненормального завершения запроса клиенту возвращается исключение. Исключение может содержать специфические параметры, специфические для данного типа исключений. Параметры.Параметр характеризуется режимом передачи и своим типом. Режим определяет, должно ли передаваться значение параметра от клиента к серверу (in), от сервера к клиенту (out) или в обоих направлениях (inout).

· Возвращаемое значение.

· Если есть возвращаемое значение, то оно рассматривается как параметр типа out.

· Исключения.

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

· Контекст.

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

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

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

Типу интерфейса удовлетворяют только объектные типы. Интерфейс ORB-а.

Интерфейс ORB-а является функциям, вызываемым непосредственно у Брокера Объектных Запросов и идентичным для всех ORB-ов, не зависящим от конкретного объекта либо адаптера объектов. Но так как большинство действий с объектами выполняется посредством адаптеров объектов, существует всего несколько общих операций, которые могут быть выполнены над каждым объектом. Эти операции могут вызываться как клиентом, так и реализацией объекта. Интерфейс динамического выполнения вызовов.

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

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

Объектно-ориентированные языки программирования, такие как C++ и Smalltalk такого интерфейса не требуют. Обзор протокола GIOP.

Спецификация протокола GIOP состоит из следующих элементов:

1. Определение Общего Представления Данных (Common Data Representation - CDR). CDR - это способ кодирования типов данных, определенных в IDL в низкоуровневое представление, пригодное для передачи их по имеющимся каналам связи между ORB-ами.

1. Формат сообщения протокола GIOP. Сообщения протокола GIOP обеспечивают нахождение объекта, отработку запросов, а также простейшее управление каналом коммуникации.

1. Предположения о транспорте. Спецификация GIOP описывает общие предположения, которые делаются при рассмотрении любого сетевого транспортного слоя, который может быть использован для обмена сообщениями протокола GIOP. Также описываются общие принципы управления соединением.

Спецификация IIOP добавляет к спецификации протокола GIOP следующий пункт:

4. Транспорт для сообщений протокола IIOP.

Спецификация IIOP описывает, каким образом агенты могут установить соединение по протоколу TCP/IP и использовать его для передачи сообщений протокола GIOP.

Протокол IIOP не является самостоятельной спецификацией - это специализированное отображение протокола GIOP поверх транспортного слоя TCP/IP. Спецификация GIOP (без элементов, специфичных для IIOP) может рассматриваться как самостоятельный документ, являющийся базовым для обеспечения в будущем отображения на новые транспортные протоколы. Протокол обмена GIOP.

За исключением редкого случая прямых вызовов методов между классами одного и того же языка программирования необходим механизм кодирования вызова метода в некоторую последовательность байт (byte stream) у клиента и декодирования этой последовательности у сервера. Для этой цели спецификация CORBA определяет Общий Протокол обмена между Брокерами Объектных Запросов (General Inter-Orb Protocol - GIOP). Кроме того, определен протокол передачи сообщений протокола GIOP поверх транспортного протокола TCP/IP, являющегося основным видом взаимодействия в Internet, ввиду чего этот протокол получил название Протокола обмена между Брокерами Объектных в Internet (Internet Inter-Orb Protocol - IIOP). Протокол IIOP должен поддерживаться всеми Брокерами Объектных Запросов независимо от особенностей их реализации, что является главным требованием для обеспечения взаимодействия между произвольными ORB-ами двух разных и совершенно независимых производителей. Особенности и цели протокола.

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

Протоколы GIOP и IIOP разрабатывались с учетом доступного широко распространенного и гибкого транспортного механизма (TCP/IP) и задает минимум дополнительных протоколов, необходимых для передачи запросов между отдельными ORB-ами. Простота.

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

Протокол GIOP/IIOP должен поддерживаться как отдельными ORB-ами, так и ORB-ами, объединенными в сеть на уровне Internet и, возможно, шире. Небольшие затраты на реализацию.

Реализация поддержки протоколов GIOP/IIOP должна потребовать минимальных затрат как в плане инженерного проектирования, так в плане распространения готовых ORB-ов. Общность.

В то время как IIOP изначально определен поверх протокола TCP/IP, сообщения, которыми происходит обмен в рамках протокола GIOP специально разработаны для реализации поверх любого протокола, который базируется на установленном между сервером и клиентом соединении. Архитектурная независимость.

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

Подход конкретного ORB-а к обеспечению поддержки протокола GIOP/IIOP не определен. Например, ORB может принять IIOP в качестве внутреннего протокола, использовать его только для внешнего обмена, используя для обмена в рамках самого ORB-а какие-то дополнительные средства коммуникации или выбрать нечто среднее между этими двумя крайностями. Все что требуется от ORB-а - это чтобы существовало нечто способное принимать и отправлять сообщения по протоколу IIOP. Формат сообщений протокола GIOP.

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

Значение, соответствующее типу сообщения Тип сообщения Кто может посылать сообщение Клиент Сервер 0. Request. Да - 1. Reply. - Да 2. CancelRequest. Да - 3. LocateRequest. Да - 4. LocateReply. - Да 5. CloseConnection. - Да 6. MessageError. Да Да

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

1. Поле magic, которое состоит из четырех символов "GIOP", идентифицирующих все сообщения протокола GIOP.

1. Поле GIOP_version, которое состоит из двух полей major и minor, идентифицирующих старший и младший номера версии используемого протокола. Текущая спецификация определяет версию 1.0. Приложение должно поддерживать взаимодействие в рамках протокола только если номер, содержащийся в поле major равен, а в поле minor - больше или равен номерам версии, используемой при разработке приложения.

1. Поле byte_order. Значение 0 в этом поле определяет, что в сообщении принято кодирование данных с лидирующим наиболее значащим байтом, 1 - наименее значащим. В настоящее время подавляющее большинство процессоров, в том числе и серия Intel x86 используется представление с лидирующим наименее значащим байтом.

1. Поле message_type содержит значение от 0 до 6, определяющее тип сообщения.

1. Поле message_size содержит длину оставшейся части сообщения (0 если больше ничего нет).

За общим заголовком каждого сообщения в зависимости от его типа может идти заголовок и тело конкретного сообщения. Структура каждого заголовка специфична для каждого типа сообщения и представляет особенного интереса для рассмотрения. Транспорт для протокола GIOP.

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

1. Транспорт ориентируется на установление соединения с последующим обменом информации в рамках соединения. Соединение используется для определения правил нумерации запросов.

1. Транспорт протокол должен гарантировать прохождение переданных байт в том порядке, в котором они были посланы.

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

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

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

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

Соединение двунаправленное в смысле потока данных, но оно не является симметричным в плане обмена сообщениями GIOP. Сообщения Request, LocateRequest и CancelRequest могут посылаться только клиентом. Сообщения Reply, LocateReply и CloseConnection - только сервером. Сообщение ErrorMessage может быть послано обеими сторонами. Через соединение для обмена в соответствии с протоколом GIOP могут посылаться только сообщения GIOP.

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

Соединение может быть либо закрыто в рамках протокола, либо разорваться. Закрытие соединения может инициироваться со стороны сервера посредством посылки сообщения CloseConnection или клиентом посредством обычного закрытия соединения в произвольный момент времени. Если на момент закрытия соединения имеются неотработанные запросы, то сервер должен рассматривать такие запросы как отмененные. Сервер не может послать сообщение CloseConnection, если он начал обработку запроса, для которого не поступило сообщения CancelRequest, или он (сервер) не послал ответного сообщения.

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

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

Язык описания интерфейсов (IDL), используемый OMG определяет типы объектов посредством спецификации их интерфейсов. Интерфейс состоит из множества именованных операций и их параметров. Хотя и описание на IDL обеспечивает ORB всей необходимой информацией о типе объекта, для работы вовсе необязательно, чтобы ORB-у был доступен исходный текст этих описаний. Эта же информация может быть заложена также в виде заглушек со стороны клиента и скелета со стороны сервера, а также в динамически изменяемом хранилище описаний, что позволит ORB-у нормально функционировать.

Язык описания интерфейсов рассматривается как средство, с помощью которого реализация объекта сообщает своим потенциальным клиентам о том, какие операции доступны и каким образом их следует вызывать. Можно оттранслировать описание на языке IDL в исходный код на конкретном языке программирования. Отображение IDL в языки программирования.

Различные объектно-ориентированные или объектно-неориентированные языки программирования могут получать доступ к объектам различным образом. Для объектно-ориентированных языков допускается отображение объектов, доступных ORB-у в объекты в смысле этих языков программирования. Даже для объектно-неориентированных языков декорирование настоящего представления ссылок на объекты будет полезным. Конкретное отображение IDL для языка программирования должно быть идентичным для всех реализаций ORB-ов. Отображение для языка программирования включает в себя определение специфичных для языка программирования типов данных и описания процедур доступа к объектам посредством ORB-а. Оно также включает в себя интерфейс для доступа клиента к заглушке, что может не требоваться для объектно-ориентированных языков, интерфейс динамических вызовов, скелет реализации, описание адаптеров объектов и прямой интерфейс к ORB-у.

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

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

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

Определены следующие основные (базовые) типы данных:

· 16 и 32 разрядные знаковые и беззнаковые целые типы;

· 32 и 64 разрядные типы с плавающей точкой в соответствии с IEEE;

· символьный тип в соответствии с ISO Latin-1 (8859.1);

· логический тип с множеством значений истина и ложь;

· 8 разрядный тип, который гарантированно не подвергается никаким изменениям при передаче между различными системами;

· перечислимые типы, состоящие из последовательности идентификаторов;

· строковый тип, состоящий из последовательности символов переменной длины, длина строки доступна во время выполнения программы;

· тип "any", который может принимать значения всех базовых и составных типов.

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

· структура, состоящая из упорядоченных пар (имя, значение);

· объединение, состоящее из дискриминатора и значения типа, связанного с дискриминатором;

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

· массив фиксированной длины, элементами которого являются значения одного типа;

· тип интерфейс, который определяет множество операций, которое должен поддерживать экземпляр этого типа.

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

CDR - это способ представления всех типов данных, определенных в OMG IDL в виде последовательности восьмиразрядных величин, далее называемых байтами.

Поток байт представляет из себя некоторую абстракцию обычно соответствующую буферу данных, который передается между процессами или машинами с помощью средств IPC или сетевого транспорта. Далее считается, что поток байт или просто поток - это последовательность переменной (но конечной) длины величин, состоящих из 8 бит (байт) с четко определенным заголовком. Байты в потоке нумеруются от 0 до n-1, где n - это длина потока. Индекс каждого байта используется для вычисления границ выравнивания, как это описано далее.

Протокол GIOP определяет два вида потоков - сообщение и инкапсуляция. Сообщение - это основная единица обмена информацией в протоколе GIOP. Инкапсуляция - это поток, внутри которого любая структура данных, имеющаяся в OMG IDL может быть декодирована независимо от остального контекста сообщения. Инкапсуляция позволяет осуществлять предварительное кодирование сложных типов данных (таких как TypeCode) или обрабатывать части сообщений без требования полного его декодирования. Кодирование базовых типов.

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

Для того, чтобы сделать возможным помещение и извлечение значений базовых типов в поток и из потока с помощью подпрограмм, предназначенных для работы именно с этими типами данных, все базовые типы данных при помещении в поток должны быть выровнены на свою естественную границу, то есть на число байт, которое нацело делится на число байт, необходимых для представления этого типа. Таким образом значение, имеющее размер n должно кодироваться с позиции m*n, где m - это целое число. В CDR n может принимать значения 1, 2, 4 или 8. Если необходимо, то выровненному значению предшествует область минимально возможного размера, необходимого для выравнивания. Значение байтов внутри этой области не определено.

Выравнивание определяется относительно начала потока. Первый байт в сообщении или инкапсуляции имеет индекс 0. Кодирование составных типов.

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

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

Объединение кодируется значением дискриминатора и членом объединения, соответствующим данному значению.

Массив кодируется как последовательность его элементов. Так как длина массива фиксирована, она не кодируется. Если массив имеет несколько измерений, то первый индекс изменяется наиболее медленно, а последний - наиболее быстро.

Последовательность элементов кодируется как величина типа unsigned long, за которым следуют элементы последовательности. Это значение определяет количество элементов. Каждый элемент кодируется в соответствии со своим типом.

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

Значение перечислимого типа кодируется в виде величины типа unsigned long, соответствующей данному значению. Первому в порядке перечисления в определении на IDL значению соответствует 0, второму - 1 и так далее. Кодирование инкапсуляции.

Первый байт инкапсуляции кодирует порядок байт внутри нее - значение типа 0 означает кодирования по принципу первым - старший байт, 1 - младший. Далее идут данные. Флаг порядка байт не включается в данные, но он включается в инкапсуляцию. Все значения внутри инкапсуляции выравниваются относительно ее начала, первый байт (с индексом 0) соответственно занимает флаг порядка байт. Если инкапсуляция кодируется как последовательность величин типа octet (байтов), то ей предшествует значение типа unsigned long, содержащее общий размер инкапсуляции. Никакого выравнивания для инкапсуляции не предполагается, но такой способ кодирования всегда гарантирует 4-байтное выравнивание для первого байта инкапсуляции. Кодирование псевдообъектов.

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

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

· спецификации параметров, требуемых для выполнения операции

· спецификации возвращаемого значения

· спецификации исключения, которые могут возникнуть во время выполнения операции и типов данных, которые соответствуют этим исключениям

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

· индикации семантики, которую клиент должен учитывать при выполнении операции.

Хранилище описаний.

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

©Drkb::04356.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

CRC.

Code: { Example of calculating a simple checksum. Beispiel, wie eine einfache Checksumme berechnet werden kann. } Function CalcStrChecksum(s: string; zerobased: Boolean): Longint; Var. I: integer; L: integer; Begin. Result := 0; L := Length(s); If l > 0 then. Begin. For i := 1 to l do. If zerobased then. Inc(Result, Ord(s[i]) - 65). Else. Inc(Result, Ord(s[i])); End; End;

CRC-64.

Автор: Nikonov A.A.

Code: Unit psnCRC64; Interface. Uses Classes; Procedure CRC64Next(const Data; const Count: Cardinal; var CRC64: Int64); Function CRC64Full(const Data; const Count: Cardinal): Int64; Function CRC64Stream(const Source: TStream; Count: Integer; const BufSize: Cardinal = 1024): Int64; Implementation. Var T: array[Byte] of Int64; Procedure CRC64Next(const Data; const Count: Cardinal; var CRC64: Int64); Var. MyCRC64: Int64; I: Cardinal; PData: ^Byte; Begin. PData := @Data; MyCRC64 := CRC64; For I := 1 to Count do. Begin. MyCRC64 := MyCRC64 shr 8 xor T[Cardinal(MyCRC64). And $FF xor PData^]; Inc(PData); End; CRC64 := MyCRC64; End; Function CRC64Full(const Data; const Count: Cardinal): Int64; Begin. Result := not 0; CRC64Next(Data, Count, Result); End; Function CRC64Stream(const Source: TStream; Count: Integer; Const BufSize: Cardinal = 1024): Int64; Var. N: Cardinal; Buffer: Pointer; Begin. If Count '<'; 0. Then Count := Source.Size; GetMem(Buffer, BufSize); Try. Result := not 0; While Count '<'; '>'; 0 do. Begin. If Cardinal(Count)'>'; BufSize. Then. N := BufSize. Else. N := Count; Source.ReadBuffer(Buffer^, N); CRC64Next(Buffer^, N, Result); Dec(Count, N); End; Finally FreeMem(Buffer); End; End; Var. I, J: Byte; D: Int64; Initialization. For I := 0 to 255 do. Begin. D := I; For J := 1 to 8 do. If Odd(D). Then D := D shr 1 xor $C96C5795D7870F42. Else D := D shr 1; T[I] := D; End; End. ///////////////////////////////////// // Данные в модуль можно загнать так. Procedure TForm1.Button1Click(Sender: TObject); Var. InFile: TFileStream; Begin. InFile := TFileStream.Create(fname, fmShareDenyNone); Caption := INTTOHEX(CRC64Stream(INFILE, SIZEOF(INFILE), 1024), 16); End;

©Drkb::03970.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Создание и регистрация Action на низком уровне.

Функция CreateAction (AOwner: TComponent;ActionClass: TBasicActionClass ):TBasicAction;

Модуль: ActnList.

Функция создает действие (Action) заданного типа, которое отображается во время проектирования в редакторе списка Action.

Тип Action указывается в параметре ActionClass.

Вызов функции аналогичен выполнению кода ActionClass.Create(AOwner), за исключением того, что функция CreateAction использует значение параметра Resource процедуры RegisterActions для инициализации значений action-объекта, основанного на данном параметре.

Процедура EnumRegisteredActions (Proc: TEnumActionProc;Info: Pointer );

Модуль: ActnList.

TEnumActionProc = Procedure( const Category: string;ActionClass: TBasicActionClass;

Info: Pointer ) of object;

Процедура производит итерацию списка зарегистрированных действий (Action), передавая их процедуре повторного вызова, определенной в параметре Proc.

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

Процедура RegisterActions (const CategoryName: string;const AClasses: array of TBasicActionClass;Resource: TcomponentClass );

Модуль: ActnList.

Процедура регистрирует множество Action так, чтобы ими можно было оперировать с помощью редактора списка Action (Action list editor).

Зарегистрированный класс будет отображаться в "Action list editor" при выборе команды редактора "New Action".

Процедура UnRegisterActions (const AClasses: array of TBasicActionClass );

Модуль: ActnList.

Отменяет регистрацию множества Action, зарегистрированных ранее процедурой RegisterActions. Множество Action определяется параметром AClasses.

©Drkb::01191.

Взято с http://atrussk.ru/delphi/

Create a TWebBrowser at Runtime?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Wb: TWebBrowser; Begin. Wb := TWebBrowser.Create(Form1); TWinControl(wb).Name := 'MyWebBrowser'; TWinControl(wb).Parent := Form1; Wb.Align := alClient; // TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet ). Wb.Navigate('http://www.swissdelphicenter.ch'); End;

CreateProcess, который возвращает консольный вывод

Code: Procedure ExecConsoleApp(CommandLine: AnsiString; Output: TStringList; Errors: TStringList); Var. Sa: TSECURITYATTRIBUTES; Si: TSTARTUPINFO; Pi: TPROCESSINFORMATION; HPipeOutputRead: THANDLE; HPipeOutputWrite: THANDLE; HPipeErrorsRead: THANDLE; HPipeErrorsWrite: THANDLE; Res, bTest: Boolean; Env: array[0..100] of Char; SzBuffer: array[0..256] of Char; DwNumberOfBytesRead: DWORD; Stream: TMemoryStream; Begin. Sa.nLength := sizeof(sa); Sa.bInheritHandle := true; Sa.lpSecurityDescriptor := nil; CreatePipe(hPipeOutputRead, hPipeOutputWrite, @sa, 0); CreatePipe(hPipeErrorsRead, hPipeErrorsWrite, @sa, 0); ZeroMemory(@env, SizeOf(env)); ZeroMemory(@si, SizeOf(si)); ZeroMemory(@pi, SizeOf(pi)); Si.cb := SizeOf(si); Si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; Si.wShowWindow := SW_HIDE; Si.hStdInput := 0; Si.hStdOutput := hPipeOutputWrite; Si.hStdError := hPipeErrorsWrite; (* Remember that if you want to execute an app with no parameters you nil the. Second parameter and use the first, you can also leave it as is with no. Problems. *). Res := CreateProcess(nil, pchar(CommandLine), nil, nil, true, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, @env, nil, si, pi); // Procedure will exit if CreateProcess fail. If not Res then. Begin. CloseHandle(hPipeOutputRead); CloseHandle(hPipeOutputWrite); CloseHandle(hPipeErrorsRead); CloseHandle(hPipeErrorsWrite); Exit; End; CloseHandle(hPipeOutputWrite); CloseHandle(hPipeErrorsWrite); //Read output pipe. Stream := TMemoryStream.Create; Try. While true do. Begin. BTest := ReadFile(hPipeOutputRead, szBuffer, 256, dwNumberOfBytesRead, Nil); If not bTest then. Begin. Break; End; Stream.Write(szBuffer, dwNumberOfBytesRead); End; Stream.Position := 0; Output.LoadFromStream(Stream); Finally. Stream.Free; End; //Read error pipe. Stream := TMemoryStream.Create; Try. While true do. Begin. BTest := ReadFile(hPipeErrorsRead, szBuffer, 256, dwNumberOfBytesRead, Nil); If not bTest then. Begin. Break; End; Stream.Write(szBuffer, dwNumberOfBytesRead); End; Stream.Position := 0; Errors.LoadFromStream(Stream); Finally. Stream.Free; End; WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); CloseHandle(hPipeOutputRead); CloseHandle(hPipeErrorsRead); End; (* got it from yahoo groups, so no copyrights for this piece :p and and example. Of how to use it. put a button and a memo to a form. *). Procedure TForm1.Button1Click(Sender: TObject); Var. OutP: TStringList; ErrorP: TStringList; Begin. OutP := TStringList.Create; ErrorP := TstringList.Create; ExecConsoleApp('ping localhost', OutP, ErrorP); Memo1.Lines.Assign(OutP); OutP.Free; ErrorP.Free; End;

Creating resource files.

You can use the Borland Command Line Resource Compiler (BRCC.EXE and BRCC32.EXE) that ships with Delphi and C++ Builder, or a WYSIWYG resource editor such as Borland's Resource Workshop 5.0 that ships with the Borland RAD Pack. The Resource Workshop 5.0 can compile and decompile both 16 and 32 bit resources from .rc, .res, .exe, .dll, .drv, .vbx, .cpl, .ico,. bmp, .rle, .dlg, fnt, and cur files.

©Drkb::02161.

Список ресурсов - источников материалов DRKB.

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

Http://blackman.wp-club.net/

Http://delphi4all.narod.ru.

Http://www.lmc-mediaagentur.de/dpool/

Http://forum.pascal.dax.ru/

Http://www.swissdelphicenter.ch/en/tipsindex.php.

Http://delphi.h5.ru.

Www.delphiworld.narod.ru.

Http://kladovka.net.ru.

Http://rouse.drkb.ru.

CRT для консольного приложения.

Code: $IfDef VER130}. {$Define NEW_STYLES}. {$EndIf}. {$IfDef VER140}. {$Define NEW_STYLES}. {$EndIf}. {..$Define HARD_CRT} {Redirect STD_...}. {..$Define CRT_EVENT} {CTRL-C,...}. {$Define MOUSE_IS_USED} {Handle mouse or not}. {..$Define OneByOne} {Block or byte style write}. Unit CRT32; Interface. {$IfDef Win32}. Const. { CRT modes of original CRT unit }. BW40 = 0; { 40x25 B/W on Color Adapter }. CO40 = 1; { 40x25 Color on Color Adapter }. BW80 = 2; { 80x25 B/W on Color Adapter }. CO80 = 3; { 80x25 Color on Color Adapter }. Mono = 7; { 80x25 on Monochrome Adapter }. Font8x8 = 256;{ Add-in for ROM font }. { Mode constants for 3.0 compatibility of original CRT unit }. C40 = CO40; C80 = CO80; { Foreground and background color constants of original CRT unit }. Black = 0; Blue = 1; Green = 2; Cyan = 3; Red = 4; Magenta = 5; Brown 6; LightGray = 7; { Foreground color constants of original CRT unit }. DarkGray = 8; LightBlue = 9; LightGreen = 10; LightCyan = 11; LightRed = 12; LightMagenta = 13; Yellow = 14; White = 15; { Add-in for blinking of original CRT unit }. Blink = 128; { } { New constans there are not in original CRT unit }. { } MouseLeftButton = 1; MouseRightButton = 2; MouseCenterButton = 4; Var. { Interface variables of original CRT unit }. CheckBreak: Boolean; { Enable Ctrl-Break }. CheckEOF: Boolean; { Enable Ctrl-Z }. DirectVideo: Boolean; { Enable direct video addressing }. CheckSnow: Boolean; { Enable snow filtering }. LastMode: Word; { Current text mode }. TextAttr: Byte; { Current text attribute }. WindMin: Word; { Window upper left coordinates }. WindMax: Word; { Window lower right coordinates }. { } { New variables there are not in original CRT unit }. { } MouseInstalled: boolean; MousePressedButtons: word; { Interface functions & procedures of original CRT unit }. Procedure AssignCrt(var F: Text); Function KeyPressed: Boolean; Function ReadKey: char; Procedure TextMode(Mode: Integer); Procedure Window(X1, Y1, X2, Y2: Byte); Procedure GotoXY(X, Y: Byte); Function WhereX: Byte; Function WhereY: Byte; Procedure ClrScr; Procedure ClrEol; Procedure InsLine; Procedure DelLine; Procedure TextColor(Color: Byte); Procedure TextBackground(Color: Byte); Procedure LowVideo; Procedure HighVideo; Procedure NormVideo; Procedure Delay(MS: Word); Procedure Sound(Hz: Word); Procedure NoSound; { New functions & procedures there are not in original CRT unit }. Procedure FillerScreen(FillChar: Char); Procedure FlushInputBuffer; Function GetCursor: Word; Procedure SetCursor(NewCursor: Word); Function MouseKeyPressed: Boolean; Procedure MouseGotoXY(X, Y: Integer); Function MouseWhereY: Integer; Function MouseWhereX: Integer; Procedure MouseShowCursor; Procedure MouseHideCursor; { These functions & procedures are for inside use only }. Function MouseReset: Boolean; Procedure WriteChrXY(X, Y: Byte; Chr: char); Procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer); Procedure OverwriteChrXY(X, Y: Byte; Chr: char); {$EndIf Win32}. Implementation. {$IfDef Win32}. Uses Windows, SysUtils; Type. POpenText = ^TOpenText; TOpenText = function(var F: Text; Mode: Word): Integer; far; Var. IsWinNT: boolean; PtrOpenText: POpenText; HConsoleInput: THandle; HConsoleOutput: THandle; ConsoleScreenRect: TSmallRect; StartAttr: word; LastX, LastY: byte; SoundDuration: integer; SoundFrequency: integer; OldCP: integer; MouseRowWidth, MouseColWidth: word; MousePosX, MousePosY: smallInt; MouseButtonPressed: boolean; MouseEventTime: TDateTime; { } { This function handles the Write and WriteLn commands }. { } Function TextOut(var F: Text): Integer; far; {$IfDef OneByOne}. Var. DwSize: DWORD; {$EndIf}. Begin. With TTExtRec(F) do. Begin. If BufPos > 0 then. Begin. LastX := WhereX; LastY := WhereY; {$IfDef OneByOne}. DwSize := 0; While (dwSize < BufPos) do. Begin. WriteChrXY(LastX, LastY, BufPtr[dwSize]); Inc(dwSize); End; {$Else}. WriteStrXY(LastX, LastY, BufPtr, BufPos); FillChar(BufPtr^, BufPos + 1, #0); {$EndIf}. BufPos := 0; End; End; Result := 0; End; { } { This function handles the exchanging of Input or Output }. { } Function OpenText(var F: Text; Mode: Word): Integer; far; Var. OpenResult: integer; Begin. OpenResult := 102; { Text not assigned }. If Assigned(PtrOpenText) then. Begin. TTextRec(F).OpenFunc := PtrOpenText; OpenResult := PtrOpenText^(F, Mode); If OpenResult = 0 then. Begin. If Mode = fmInput then. HConsoleInput := TTextRec(F).Handle. Else. Begin. HConsoleOutput := TTextRec(F).Handle; TTextRec(Output).InOutFunc := @TextOut; TTextRec(Output).FlushFunc := @TextOut; End; End; End; Result := OpenResult; End; { } { Fills the current window with special character }. { } Procedure FillerScreen(FillChar: Char); Var. Coord: TCoord; DwSize, dwCount: DWORD; Y: integer; Begin. Coord.X := ConsoleScreenRect.Left; DwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1; For Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do. Begin. Coord.Y := Y; FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount); End; GotoXY(1,1); End; { } { Write one character at the X,Y position }. { } Procedure WriteChrXY(X, Y: Byte; Chr: char); Var. Coord: TCoord; DwSize, dwCount: DWORD; Begin. LastX := X; LastY := Y; Case Chr of. #13: LastX := 1; #10: Begin. LastX := 1; Inc(LastY); End; Else. Begin. Coord.X := LastX - 1 + ConsoleScreenRect.Left; Coord.Y := LastY - 1 + ConsoleScreenRect.Top; DwSize := 1; FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount); Inc(LastX); End; End; If (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then. Begin. LastX := 1; Inc(LastY); End; If (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then. Begin. Dec(LastY); GotoXY(1,1); DelLine; End; GotoXY(LastX, LastY); End; { } { Write string into the X,Y position }. { } (* !!! The WriteConsoleOutput does not write into the last line !!! Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer ); {$IfDef OneByOne}. Var. DwCount: integer; {$Else}. Type. PBuffer= ^TBuffer; TBUffer= packed array [0..16384] of TCharInfo; Var. I: integer; DwCount: DWORD; WidthHeight,Coord: TCoord; HTempConsoleOutput: THandle; SecurityAttributes: TSecurityAttributes; Buffer: PBuffer; DestinationScreenRect,SourceScreenRect: TSmallRect; {$EndIf}. Begin. If dwSize>0 Then Begin. {$IfDef OneByOne}. LastX:=X; LastY:=Y; DwCount:=0; While dwCount < dwSize Do Begin. WriteChrXY(LastX,LastY,Str[dwCount]); Inc(dwCount); End; {$Else}. SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD); SecurityAttributes.lpSecurityDescriptor:=NIL; SecurityAttributes.bInheritHandle:=TRUE; HTempConsoleOutput:=CreateConsoleScreenBuffer( GENERIC_READ OR GENERIC_WRITE, FILE_SHARE_READ OR FILE_SHARE_WRITE, @SecurityAttributes, CONSOLE_TEXTMODE_BUFFER, NIL. ); If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin. WidthHeight.X:=dwSize; WidthHeight.Y:=1; End Else Begin. WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1; WidthHeight.Y:=dwSize DIV WidthHeight.X; If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y); End; SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight); DestinationScreenRect.Left:=0; DestinationScreenRect.Top:=0; DestinationScreenRect.Right:=WidthHeight.X-1; DestinationScreenRect.Bottom:=WidthHeight.Y-1; SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect); Coord.X:=0; For I:=1 To WidthHeight.Y Do Begin. Coord.Y:=I-0; FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount); FillConsoleOutputCharacter(hTempConsoleOutput,' ' ,WidthHeight.X,Coord,dwCount); End; WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL); { } New(Buffer); Coord.X:= 0; Coord.Y:= 0; SourceScreenRect.Left:=0; SourceScreenRect.Top:=0; SourceScreenRect.Right:=WidthHeight.X-1; SourceScreenRect.Bottom:=WidthHeight.Y-1; ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect); Coord.X:=X-1; Coord.Y:=Y-1; DestinationScreenRect:=ConsoleScreenRect; WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect); GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1); Dispose(Buffer); { } CloseHandle(hTempConsoleOutput); {$EndIf}. End; End; *) Procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer); {$IfDef OneByOne}. Var. DwCount: integer; {$Else}. Var. I: integer; LineSize, dwCharCount, dwCount, dwWait: DWORD; WidthHeight: TCoord; OneLine: packed array [0..131] of char; Line, TempStr: PChar; Procedure NewLine; Begin. LastX := 1; Inc(LastY); If (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then. Begin. Dec(LastY); GotoXY(1,1); DelLine; End; GotoXY(LastX, LastY); End; {$EndIf}. Begin. If dwSize > 0 then. Begin. {$IfDef OneByOne}. LastX := X; LastY := Y; DwCount := 0; While dwCount < dwSize do. Begin. WriteChrXY(LastX, LastY, Str[dwCount]); Inc(dwCount); End; {$Else}. LastX := X; LastY := Y; GotoXY(LastX, LastY); DwWait := dwSize; TempStr := Str; While (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do. Begin. Dec(dwWait, 2); Inc(TempStr, 2); NewLine; End; While (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do. Begin. Dec(dwWait); Inc(TempStr); NewLine; End; If dwWait > 0 then. Begin. If dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then. Begin. WidthHeight.X := dwSize + LastX - 1; WidthHeight.Y := 1; End. Else. Begin. WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1; WidthHeight.Y := dwSize div WidthHeight.X; If (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y); End; For I := 1 to WidthHeight.Y do. Begin. FillChar(OneLine, SizeOf(OneLine), #0); Line := @OneLine; LineSize := WidthHeight.X - LastX + 1; If LineSize > dwWait then LineSize := dwWait; Dec(dwWait, LineSize); StrLCopy(Line, TempStr, LineSize); Inc(TempStr, LineSize); DwCharCount := Pos(#13#10, StrPas(Line)); If dwCharCount > 0 then. Begin. OneLine[dwCharCount - 1] := #0; OneLine[dwCharCount] := #0; WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil); Inc(Line, dwCharCount + 1); NewLine; LineSize := LineSize - (dwCharCount + 1); End. Else. Begin. DwCharCount := Pos(#10, StrPas(Line)); If dwCharCount > 0 then. Begin. OneLine[dwCharCount - 1] := #0; WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil); Inc(Line, dwCharCount); NewLine; LineSize := LineSize - dwCharCount; End; End; If LineSize <> 0 then. Begin. WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil); End; If dwWait > 0 then. Begin. NewLine; End; End; End; {$EndIf}. End; End; { } { Empty the buffer }. { } Procedure FlushInputBuffer; Begin. FlushConsoleInputBuffer(hConsoleInput); End; { } { Get size of current cursor }. { } Function GetCursor: Word; Var. CCI: TConsoleCursorInfo; Begin. GetConsoleCursorInfo(hConsoleOutput, CCI); GetCursor := CCI.dwSize; End; { } { Set size of current cursor }. { } Procedure SetCursor(NewCursor: Word); Var. CCI: TConsoleCursorInfo; Begin. If NewCursor = $0000 then. Begin. CCI.dwSize := GetCursor; CCI.bVisible := False; End. Else. Begin. CCI.dwSize := NewCursor; CCI.bVisible := True; End; SetConsoleCursorInfo(hConsoleOutput, CCI); End; { } { --- Begin of Interface functions & procedures of original CRT unit --- }. Procedure AssignCrt(var F: Text); Begin. Assign(F, ''); TTextRec(F).OpenFunc := @OpenText; End; Function KeyPressed: Boolean; Var. NumberOfEvents: DWORD; NumRead: DWORD; InputRec: TInputRecord; Pressed: boolean; Begin. Pressed := False; GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents); If NumberOfEvents > 0 then. Begin. If PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then. Begin. If (InputRec.EventType = KEY_EVENT) and. (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then. Begin. Pressed := True; {$IfDef MOUSE_IS_USED}. MouseButtonPressed := False; {$EndIf}. End. Else. Begin. {$IfDef MOUSE_IS_USED}. If (InputRec.EventType = _MOUSE_EVENT) then. Begin. With InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do. Begin. MousePosX := dwMousePosition.X; MousePosY := dwMousePosition.Y; If dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then. Begin. MouseEventTime := Now; MouseButtonPressed := True; {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}. {End;}. End; End; End; ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead); {$Else}. ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead); {$EndIf}. End; End; End; Result := Pressed; End; Function ReadKey: char; Var. NumRead: DWORD; InputRec: TInputRecord; Begin. Repeat. Repeat. Until KeyPressed; ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead); Until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0; Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar; End; Procedure TextMode(Mode: Integer); Begin. End; Procedure Window(X1, Y1, X2, Y2: Byte); Begin. ConsoleScreenRect.Left := X1 - 1; ConsoleScreenRect.Top := Y1 - 1; ConsoleScreenRect.Right := X2 - 1; ConsoleScreenRect.Bottom := Y2 - 1; WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left; WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right; {$IfDef WindowFrameToo}. SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect); {$EndIf}. GotoXY(1,1); End; Procedure GotoXY(X, Y: Byte); Var. Coord: TCoord; Begin. Coord.X := X - 1 + ConsoleScreenRect.Left; Coord.Y := Y - 1 + ConsoleScreenRect.Top; If not SetConsoleCursorPosition(hConsoleOutput, Coord) then. Begin. GotoXY(1, 1); DelLine; End; End; Function WhereX: Byte; Var. CBI: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hConsoleOutput, CBI); Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left; End; Function WhereY: Byte; Var. CBI: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hConsoleOutput, CBI); Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top; End; Procedure ClrScr; Begin. FillerScreen(' '); End; Procedure ClrEol; Var. Coord: TCoord; DwSize, dwCount: DWORD; Begin. Coord.X := WhereX - 1 + ConsoleScreenRect.Left; Coord.Y := WhereY - 1 + ConsoleScreenRect.Top; DwSize := ConsoleScreenRect.Right - Coord.X + 1; FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount); End; Procedure InsLine; Var. SourceScreenRect: TSmallRect; Coord: TCoord; CI: TCharInfo; DwSize, dwCount: DWORD; Begin. SourceScreenRect := ConsoleScreenRect; SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top; SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1; CI.AsciiChar := ' '; CI.Attributes := TextAttr; Coord.X := SourceScreenRect.Left; Coord.Y := SourceScreenRect.Top + 1; DwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1; ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI); Dec(Coord.Y); FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); End; Procedure DelLine; Var. SourceScreenRect: TSmallRect; Coord: TCoord; CI: TCharinfo; DwSize, dwCount: DWORD; Begin. SourceScreenRect := ConsoleScreenRect; SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top; CI.AsciiChar := ' '; CI.Attributes := TextAttr; Coord.X := SourceScreenRect.Left; Coord.Y := SourceScreenRect.Top - 1; DwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1; ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI); FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); End; Procedure TextColor(Color: Byte); Begin. LastMode := TextAttr; TextAttr := (Color and $0F) or (TextAttr and $F0); SetConsoleTextAttribute(hConsoleOutput, TextAttr); End; Procedure TextBackground(Color: Byte); Begin. LastMode := TextAttr; TextAttr := (Color shl 4) or (TextAttr and $0F); SetConsoleTextAttribute(hConsoleOutput, TextAttr); End; Procedure LowVideo; Begin. LastMode := TextAttr; TextAttr := TextAttr and $F7; SetConsoleTextAttribute(hConsoleOutput, TextAttr); End; Procedure HighVideo; Begin. LastMode := TextAttr; TextAttr := TextAttr or $08; SetConsoleTextAttribute(hConsoleOutput, TextAttr); End; Procedure NormVideo; Begin. LastMode := TextAttr; TextAttr := StartAttr; SetConsoleTextAttribute(hConsoleOutput, TextAttr); End; Procedure Delay(MS: Word); { Const. Magic= $80000000; Var. StartMS,CurMS,DeltaMS: DWORD; } Begin. Windows.SleepEx(MS, False); // Windows.Sleep(MS); { StartMS:= GetTickCount; Repeat. CurMS:= GetTickCount; If CurMS >= StartMS Then. DeltaMS:= CurMS - StartMS. Else DeltaMS := (CurMS + Magic) - (StartMS - Magic); Until MS<DeltaMS; } End; Procedure Sound(Hz: Word); Begin. {SetSoundIOPermissionMap(LocalIOPermission_ON);}. SoundFrequency := Hz; If IsWinNT then. Begin. Windows.Beep(SoundFrequency, SoundDuration). End. Else. Begin. Asm. Mov BX,Hz. Cmp BX,0. Jz @2. Mov AX,$34DD. Mov DX,$0012. Cmp DX,BX. Jnb @2. Div BX. Mov BX,AX. { Sound is On ? }. In Al,$61. Test Al,$03. Jnz @1. { Set Sound On }. Or Al,03. Out $61,Al. { Timer Command }. Mov Al,$B6. Out $43,Al. { Set Frequency }. @1: mov Al,Bl. Out $42,Al. Mov Al,Bh. Out $42,Al. @2: End; End; End; Procedure NoSound; Begin. If IsWinNT then. Begin. Windows.Beep(SoundFrequency, 0); End. Else. Begin. Asm. { Set Sound On }. In Al,$61. And Al,$FC. Out $61,Al. End; End; {SetSoundIOPermissionMap(LocalIOPermission_OFF);}. End; { --- End of Interface functions & procedures of original CRT unit --- }. { } Procedure OverwriteChrXY(X, Y: Byte; Chr: char); Var. Coord: TCoord; DwSize, dwCount: DWORD; Begin. LastX := X; LastY := Y; Coord.X := LastX - 1 + ConsoleScreenRect.Left; Coord.Y := LastY - 1 + ConsoleScreenRect.Top; DwSize := 1; FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount); FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount); GotoXY(LastX, LastY); End; { -------------------------------------------------- } { Console Event Handler }. { } {$IfDef CRT_EVENT}. Function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far; Var. S: {$IfDef Win32}ShortString{$Else}String{$EndIf}; Message: PChar; Begin. Case CtrlType of. CTRL_C_EVENT: S := 'CTRL_C_EVENT'; CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT'; CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT'; CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT'; CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT'; Else. S := 'UNKNOWN_EVENT'; End; S := S + ' detected, but not handled.'; Message := @S; Inc(Message); MessageBox(0, Message, 'Win32 Console', MB_OK); Result := True; End; {$EndIf}. Function MouseReset: Boolean; Begin. MouseColWidth := 1; MouseRowWidth := 1; Result := True; End; Procedure MouseShowCursor; Const. ShowMouseConsoleMode = ENABLE_MOUSE_INPUT; Var. CMode: DWORD; Begin. GetConsoleMode(hConsoleInput, cMode); If (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then. Begin. CMode := cMode or ShowMouseConsoleMode; SetConsoleMode(hConsoleInput, cMode); End; End; Procedure MouseHideCursor; Const. ShowMouseConsoleMode = ENABLE_MOUSE_INPUT; Var. CMode: DWORD; Begin. GetConsoleMode(hConsoleInput, cMode); If (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then. Begin. CMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode); SetConsoleMode(hConsoleInput, cMode); End; End; Function MouseKeyPressed: Boolean; {$IfDef MOUSE_IS_USED}. Const. MouseDeltaTime = 200; Var. ActualTime: TDateTime; HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word; MSecTimeA, MSecTimeM: longInt; MSecDelta: longInt; {$EndIf}. Begin. MousePressedButtons := 0; {$IfDef MOUSE_IS_USED}. Result := False; If MouseButtonPressed then. Begin. ActualTime := NOW; DecodeTime(ActualTime, HourA, MinA, SecA, MSecA); DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM); MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA; MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM; MSecDelta := Abs(MSecTimeM - MSecTimeA); If (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then. Begin. MousePressedButtons := MouseLeftButton; MouseButtonPressed := False; Result := True; End; End; {$Else}. Result := False; {$EndIf}. End; Procedure MouseGotoXY(X, Y: Integer); Begin. {$IfDef MOUSE_IS_USED}. Mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo()); MousePosY := (Y - 1) * MouseRowWidth; MousePosX := (X - 1) * MouseColWidth; {$EndIf}. End; Function MouseWhereY: Integer; {$IfDef MOUSE_IS_USED}. {Var. Lppt, lpptBuf: TMouseMovePoint;}. {$EndIf}. Begin. {$IfDef MOUSE_IS_USED}. {GetMouseMovePoints( SizeOf(TMouseMovePoint), lppt, lpptBuf, 7,GMMP_USE_DRIVER_POINTS. ); Result:=lpptBuf.Y DIV MouseRowWidth;}. Result := (MousePosY div MouseRowWidth) + 1; {$Else}. Result := -1; {$EndIf}. End; Function MouseWhereX: Integer; {$IfDef MOUSE_IS_USED}. {Var. Lppt, lpptBuf: TMouseMovePoint;}. {$EndIf}. Begin. {$IfDef MOUSE_IS_USED}. {GetMouseMovePoints( SizeOf(TMouseMovePoint), lppt, lpptBuf, 7,GMMP_USE_DRIVER_POINTS. ); Result:=lpptBuf.X DIV MouseColWidth;}. Result := (MousePosX div MouseColWidth) + 1; {$Else}. Result := -1; {$EndIf}. End; { } Procedure Init; Const. ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT; ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT; Var. CMode: DWORD; Coord: TCoord; OSVersion: TOSVersionInfo; CBI: TConsoleScreenBufferInfo; Begin. OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); GetVersionEx(OSVersion); If OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then. IsWinNT := True. Else. IsWinNT := False; PtrOpenText := TTextRec(Output).OpenFunc; {$IfDef HARD_CRT}. AllocConsole; Reset(Input); HConsoleInput := GetStdHandle(STD_INPUT_HANDLE); TTextRec(Input).Handle := hConsoleInput; ReWrite(Output); HConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE); TTextRec(Output).Handle := hConsoleOutput; {$Else}. Reset(Input); HConsoleInput := TTextRec(Input).Handle; ReWrite(Output); HConsoleOutput := TTextRec(Output).Handle; {$EndIf}. GetConsoleMode(hConsoleInput, cMode); If (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then. Begin. CMode := cMode or ExtInpConsoleMode; SetConsoleMode(hConsoleInput, cMode); End; TTextRec(Output).InOutFunc := @TextOut; TTextRec(Output).FlushFunc := @TextOut; GetConsoleScreenBufferInfo(hConsoleOutput, CBI); GetConsoleMode(hConsoleOutput, cMode); If (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then. Begin. CMode := cMode or ExtOutConsoleMode; SetConsoleMode(hConsoleOutput, cMode); End; TextAttr := CBI.wAttributes; StartAttr := CBI.wAttributes; LastMode := CBI.wAttributes; Coord.X := CBI.srWindow.Left; Coord.Y := CBI.srWindow.Top; WindMin := (Coord.Y shl 8) or Coord.X; Coord.X := CBI.srWindow.Right; Coord.Y := CBI.srWindow.Bottom; WindMax := (Coord.Y shl 8) or Coord.X; ConsoleScreenRect := CBI.srWindow; SoundDuration := -1; OldCp := GetConsoleOutputCP; SetConsoleOutputCP(1250); {$IfDef CRT_EVENT}. SetConsoleCtrlHandler(@ConsoleEventProc, True); {$EndIf}. {$IfDef MOUSE_IS_USED}. SetCapture(hConsoleInput); KeyPressed; {$EndIf}. MouseInstalled := MouseReset; Window(1,1,80,25); ClrScr; End; { } Procedure Done; Begin. {$IfDef CRT_EVENT}. SetConsoleCtrlHandler(@ConsoleEventProc, False); {$EndIf}. SetConsoleOutputCP(OldCP); TextAttr := StartAttr; SetConsoleTextAttribute(hConsoleOutput, TextAttr); ClrScr; FlushInputBuffer; {$IfDef HARD_CRT}. TTextRec(Input).Mode := fmClosed; TTextRec(Output).Mode := fmClosed; FreeConsole; {$Else}. Close(Input); Close(Output); {$EndIf}. End; Initialization. Init; Finalization. Done; {$Endif win32}. End.

Crtsock.pas.

Code: Unit crtsock; { CrtSocket for Delphi 32. Copyright (C) 1999-2001 Paul Toth <tothpaul@free.fr> Http://tothpaul.free.fr. This program is free software; you can redistribute it and/or. Modify it under the terms of the GNU General Public License. As published by the Free Software Foundation; either version 2. Of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, But WITHOUT ANY WARRANTY; without even the implied warranty of. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the. GNU General Public License for more details. You should have received a copy of the GNU General Public License. Along with this program; if not, write to the Free Software. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. } Interface. Uses windows,sysutils; {-$define debug}. // Server side : // - start a server. // - wait for a client. Function StartServer(Port:word):integer; Function WaitClient(Server:integer):integer; Function WaitClientEx(Server:integer; var ip:string):integer; // Client side : // - call a server. Function CallServer(Server:string;Port:word):integer; // Both side : // - Assign CRT Sockets. // - Disconnect server. Procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile); Procedure Disconnect(Socket:integer); // BroadCasting (UDP). Function StartBroadCast(Port:word):integer; Function SendBroadCast(Server:integer; Port:word; s:string):integer; Function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer; Function ReadBroadCast(Server:integer; Port:word):string; Function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string; // BlockRead. Function SockAvail(Socket:integer):integer; Function DataAvail(Var F:TextFile):integer; Function BlockReadsock(Var F:TextFile; var s:string):boolean; Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far; Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; // some usefull SOCKET apis. Type. PHost = ^THost; THost = packed record. Name : PChar; Aliases : ^PChar; Addrtype : Smallint; Length : Smallint; Addr : ^pointer; End; TSockAddr=packed record. Family:word; Port:word; Addr:LongInt; Zeros:array[0..7] of byte; End; TTimeOut=packed record. Sec:integer; Usec:integer; End; Const. FIoNbRead = $4004667F; Function socket(Family,Kind,Protocol:integer):integer; stdcall; Function closesocket(socket:Integer):integer; stdcall; Function gethostbyname(HostName:PChar):PHost; stdcall; Function gethostname(name:pchar; size:integer):integer; stdcall; Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; Function WSAGetLastError:integer; stdcall; Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall; // Convert an IP Value to xxx.xxx.xxx.xxx string. Function LongToIp(Long:LongInt):string; Function IpToLong(ip:string):longint; Function HostToLong(AHost:string):LongInt; Var. EofSock:boolean; Implementation. //------ winsock ------------------------------------------------------- Const. WinSock='wsock32.dll'; { 32bits socket DLL }. Internet=2; { Internat familly }. Stream=1; { Streamed socket }. Datagrams=2; // fIoNbRead = $4004667F; Sol_socket=$FFFF; SO_BROADCAST = $0020; { permit sending of broadcast msgs }. Type. TWSAData = packed record. WVersion: Word; WHighVersion: Word; SzDescription: array[0..256] of Char; SzSystemStatus: array[0..128] of Char; IMaxSockets: Word; IMaxUdpDg: Word; LpVendorInfo: PChar; End; { Winsock }. Function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock; Function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock; Function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock; Function closesocket(socket:Integer):integer; stdcall; far; external winsock; Function WSACleanup:integer; stdcall; far; external winsock; //Function WSAAsyncSelect(Socket:Integer; Handle:Hwnd; Msg:word; Level:Longint):longint; stdcall; far; external winsock; Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock; Function listen(socket,flags:Integer):integer; stdcall; far; external winsock; Function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock; Function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock; Function WSAGetLastError:integer; stdcall; far; external winsock; Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; external winsock; Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far; external winsock; //Function getpeername(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):Integer; stdcall; far; external winsock; Function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock; //Function getsockname(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock; //Function inet_ntoa(addr:longint):PChar; stdcall; far; external winsock; Function WSAIsBlocking:boolean; stdcall; far; external winsock; Function WSACancelBlockingCall:integer; stdcall; far; external winsock; Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall; far; external winsock; //Function gethostbyaddr(var addr:longint; size,atype:integer):PHost; stdcall; far; external winsock; Function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock; Function select(nfds:integer; readfds, writefds, exceptfds:pointer; var timeout:TTimeOut):integer; stdcall; far; external winsock; Function setsockopt(socket,level,optname:integer;var optval; optlen:integer):integer; stdcall; far; external winsock; Function sendto(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; AddrLen:Integer):integer; stdcall; far; external winsock; Function recvfrom(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; var AddrLen:Integer):integer; stdcall; far; external winsock; Function IpToLong(ip:string):LongInt; Var. X,i:byte; Ipx:array[0..3] of byte; V:integer; Begin. Result:=0; Longint(ipx):=0; i:=0; For x:=1 to length(ip) do. If ip[x]='.' then begin. Inc(i); If i=4 then exit; End else begin. If not (ip[x] in ['0'..'9']) then exit; V:=ipx[i]*10+ord(ip[x])-ord('0'); If v>255 then exit; Ipx[i]:=v; End; Result:=longint(ipx); End; Function HostToLong(AHost:string):LongInt; Var. Host:PHost; Begin. Result:=IpToLong(AHost); If Result=0 then begin. Host:=GetHostByName(PChar(AHost)); If Host<>nil then Result:=longint(Host^.Addr^^); End; End; Function LongToIp(Long:LongInt):string; Var. Ipx:array[0..3] of byte; I:byte; Begin. Longint(ipx):=long; Result:=''; For i:=0 to 3 do result:=result+IntToStr(ipx[i])+'.'; SetLength(Result,Length(Result)-1); End; //--- Server Side ------------------------------------------------------------------------ Function StartServer(Port:word):integer; Var. SockAddr:TSockAddr; Begin. Result:=socket(Internet,Stream,0); If Result=-1 then exit; FillChar(SockAddr,SizeOf(SockAddr),0); SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); If (Bind(Result,SockAddr,SizeOf(SockAddr))<>0). Or (Listen(Result,0)<>0) then begin. CloseSocket(Result); Result:=-1; End; End; Function WaitClient(Server:integer):integer; Var. Client:TSockAddr; Size:integer; Begin. Size:=SizeOf(Client); Result:=Accept(Server,Client,Size); End; Function WaitClientEx(Server:integer; var ip:string):integer; Var. Client:TSockAddr; Size:integer; Begin. Size:=SizeOf(Client); Result:=Accept(Server,Client,Size); Ip:=LongToIp(Client.Addr); End; Function SockReady(Socket:integer):boolean; Var. Sockset:packed record. Count:integer; Socks:{array[0..63] of} integer; End; Timeval:TTimeOut; Begin. SockSet.count:=1; SockSet.socks:=Socket; Timeval.sec :=0; Timeval.usec :=0; Result:=Select(0,@sockSet,nil,nil,timeval)>0; End; Function SockAvail(Socket:integer):integer; Var. Rdy:boolean; Begin. Rdy:=SockReady(Socket); // before IoCtlSocket to be sure (?) that we don't get some data between the 2 calls. If IoctlSocket(Socket, fIoNbRead,Result)<0 then. Result:=-1. Else begin. If (Result=0) and RDY then result:=-1; // SockReady is TRUE when Data ara Avaible AND when Socket is closed. End; End; Function DataAvail(Var F:TextFile):integer; Var. S:integer; Begin. // cause of TexTFile Buffer, we need to check both Buffer & Socket ! With TTextRec(F) do begin. Result:=BufEnd-BufPos; S:=SockAvail(Handle); End; If Result=0 then Result:=s else if s>0 then Inc(Result,s); End; Function BlockReadSock(Var F:TextFile; var s:string):boolean; Var. Handle:THandle; Size:integer; Begin. Result:=False; Handle:=TTextRec(F).Handle; Repeat. If (IoctlSocket(Handle, fIoNbRead, Size)<0) then exit; If Size=0 then exit. Until (Size>0); SetLength(s,Size); Recv(Handle,pchar(s),Size,0); Result:=True; End; // Client Side-------------------------------------------------------------------------- Function CallServer(Server:string; Port:word):integer; Var. SockAddr:TSockAddr; Begin. Result:=socket(Internet,Stream,0); If Result=-1 then exit; FillChar(SockAddr,SizeOf(SockAddr),0); SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); SockAddr.Addr:=HostToLong(Server); If Connect(Result,SockAddr,SizeOf(SockAddr))<>0 then begin. Disconnect(Result); Result:=-1; End; End; // BroadCasting------------------------------------- Function StartBroadCast(Port:word):integer; Var. SockAddr:TSockAddr; Bc:integer; Begin. Result:=socket(Internet,Datagrams,17); // 17 for UDP ... work also with 0 ?! If Result=-1 then exit; FillChar(SockAddr,SizeOf(SockAddr),0); SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); // SockAddr.Addr:=0; ? Bc:=SO_BROADCAST; If (Bind(Result,SockAddr,SizeOf(SockAddr))<>0). Or (setsockopt(Result,SOL_SOCKET,SO_BROADCAST,bc,SizeOf(bc))<>0) then begin. CloseSocket(Result); Result:=-1; End; End; Function SendBroadCast(Server:integer; Port:word; s:string):integer; Var. SockAddr:TSockAddr; Begin. SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); SockAddr.Addr:=-1; Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr)); End; Function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer; Var. SockAddr:TSockAddr; Begin. SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); SockAddr.Addr:=IpToLong(ip); Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr)); End; Function ReadBroadCast(Server:integer; Port:word):string; Var. SockAddr:TSockAddr; SockLen:integer; Len:integer; Begin. FillChar(SockAddr,SizeOf(SockAddr),0); SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); SockLen:=SizeOf(SockAddr); Setlength(result,1024); Len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen); If len>0 then SetLength(result,len) else result:=''; End; Function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string; Var. SockAddr:TSockAddr; SockLen:integer; Len:integer; Begin. FillChar(SockAddr,SizeOf(SockAddr),0); SockAddr.Family:=Internet; SockAddr.Port:=swap(Port); SockLen:=SizeOf(SockAddr); Setlength(result,1024); Len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen); If len>0 then SetLength(result,len) else result:=''; Ip:=LongToIp(SockAddr.Addr); End; //------------ CrtSock ----------------- Var. InitOk:boolean; Function OutputSock(Var F:TTextRec):integer; far; Begin. {$ifdef debug}writeln('out ',F.BufPtr);{$endif}. If F.BufPos<>0 then begin. Send(F.Handle,F.BufPtr,F.BufPos,0); F.BufPos:=0; End; Result:=0; End; Function InputSock(var F: TTextRec): Integer; far; Var. Size:integer; Begin. F.BufEnd:=0; F.BufPos:=0; Result:=0; Repeat. If (IoctlSocket(F.Handle, fIoNbRead, Size)<0) then begin. EofSock:=True; Exit; End; Until (Size>=0); //if Size>0 then. F.BufEnd:=Recv(F.Handle,F.BufPtr,F.BufSize,0); EofSock:=(F.BufEnd=0); {$ifdef debug}writeln('in ',F.BufPtr);{$endif}. End; Procedure Disconnect(Socket:integer); Var. Dummy:array[0..1024] of char; Begin. ShutDown(Socket,1); Repeat until recv(Socket,dummy,1024,0)<=0; CloseSocket(Socket); End; Function CloseSock(var F:TTextRec):integer; far; Begin. Disconnect(F.Handle); F.Handle:=-1; Result:=0; End; Function OpenSock(var F: TTextRec): Integer; far; Begin. F.BufPos:=0; F.BufEnd:=0; If F.Mode = fmInput then begin // ReadLn. EofSock:=False; F.InOutFunc := @InputSock; F.FlushFunc := nil; End else begin // WriteLn. F.Mode := fmOutput; F.InOutFunc := @OutputSock; F.FlushFunc := @OutputSock; End; F.CloseFunc := @CloseSock; Result:=0; End; Procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile); Begin. With TTextRec(Input) do begin. Handle := Socket; Mode := fmClosed; BufSize := SizeOf(Buffer); BufPtr := @Buffer; OpenFunc := @OpenSock; End; With TTextRec(Output) do begin. Handle := Socket; Mode := fmClosed; BufSize := SizeOf(Buffer); BufPtr := @Buffer; OpenFunc := @OpenSock; End; Reset(Input); Rewrite(Output); End; //----- Initialization/Finalization-------------------------------------------------- Procedure InitCrtSock; Var. WsaData:TWSAData; Begin. InitOk:=wsaStartup($101,wsaData)=0; {$ifdef debug}allocconsole{$endif}. End; Procedure DoneCrtSock; Begin. If not InitOk then exit; If wsaIsBlocking then wsaCancelBlockingCall; WsaCleanup; End; Initialization InitCrtSock; Finalization DoneCrtSock; End.

CryptoAPI (статья).

Delphi и Windows API для защиты секретов.

Константин Виноградов, Лилия Виноградова, "Комиздат".

Как реализовать методы криптографической защиты информации при помощи подручных средств – Windows и Delphi.

Часть 1.

Мы вступили в цифровой век. На смену бумажным документам пришли электронные, а личные контакты все чаще уступают место переписке по e-mail. Поэтому «шпионские штучки» вроде паролей и шифровок становятся все более привычными и необходимыми инструментами безопасности.

Криптографические возможности Windows.

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

Итак, ОС мы доверяем. Чтобы криптозащиту нельзя было «обойти» с другой стороны - к примеру, перехватить из незащищенной области памяти секретные пароли - криптографические функции должны быть частью операционной системы. В семействе Windows, начиная с Windows 95, обеспечивается реализация шифрования, генерации ключей, создания и проверки цифровых подписей и других криптографических задач. Эти функции необходимы для работы операционной системы, однако ими может воспользоваться и любая прикладная программа - для этого программисту достаточно обратиться к нужной подпрограмме так, как предписывает криптографический интерфейс прикладных программ (CryptoAPI).

Разумеется, по мере совершенствования Windows расширялся и состав ее криптографической подсистемы. Помимо базовых операций, в настоящее время в CryptoAPI 2.0 поддерживается работа с сертификатами, шифрованными сообщениями в формате PKCS #7 и пр.

Описание функций CryptoAPI, помимо специальных книг, можно найти в MSDN Library, или в CD-версии, в файле crypto.chm.

Взаимодействие с CryptoAPI.

Функции CryptoAPI можно вызвать из программы, написанной на любимом многими (в том числе и авторами) языке С++. Тем не менее, Pascal де-факто признан стандартом в области обучения программированию. (Не будем спорить о том, хорошо это или плохо, чтобы не ввязываться в драку, пусть даже и виртуальную.) Кроме того, в ряде отечественных компаний Delphi является базовым средством разработки. Поэтому все примеры были реализованы в среде Delphi. Хотя в качестве инструмента можно было бы выбрать и MS Visual C++.

Код функций криптографической подсистемы содержится в нескольких динамически загружаемых библиотеках Windows (advapi32.dll, crypt32.dll). Для обращения к такой функции из прикладной программы на Object Pascal следует объявить ее как внешнюю. Заголовок функции в интерфейсной части модуля будет выглядеть, например, так:

Code: Function CryptAcquireContext ( PhPROV: PHCRYPTPROV; PszContainer: LPCTSTR; PszProvider: LPCTSTR; DwProvType: DWORD; DwFlags: DWORD): BOOL; stdcall;

CryptoAPI для шифрования файлов случайными ключами

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

Как узнать версию компилятора?

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

В Дельфи предопределены специальные константы компиляции для этого:

Ver80 - Дельфи 1.

Ver90 - Дельфи 2.

Ver93 - С Buider 1.

Ver100 - Дельфи 3.

Ver110 - С Buider 3.

Ver120 - Дельфи 4.

Ver125 - С Buider 4.

Ver130 - Дельфи 5.

Ver140 - Дельфи 6.

Ver150 - Дельфи 7.

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

Code:

Procedure TForm1.Button2Click(Sender: TObject);

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

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

Версии компилятора.

Ver80 - Дельфи 1.

Ver90 - Дельфи 2.

Ver93 - С Buider 1.

Ver100 - Дельфи 3.

Ver110 - С Buider 3.

Ver120 - Дельфи 4.

Ver125 - С Buider 4.

Ver130 - Дельфи 5.

Ver140 - Дельфи 6.

Ver150 - Дельфи 7.

Ver160 - Дельфи 8.

KYLIX - Kylix 1.

KYLIX2 - Kylix 2.

KYLIX3 - Kylix 3.

KYLIX4 - Kylix 4.

Платформа: (определена для Дельфи 6 и выше).

Linux.

MSWindows.

Среда разработки:

DELPHI.

BCB.

©Drkb::00012.

Взято с Vingrad.ru http://forum.vingrad.ru.

Реагируем на щелчек по ссылке в WebBrowser.

Реагируем на щелчек по ссылке в WebBrowser.

Code: {©Drkb v.3(2007): www.drkb.ru}. Var. Document: IHtmlDocument2; V: Variant; Procedure TForm1.FormCreate(Sender: TObject); Begin. WebBrowser1.Navigate('about:blank'); While WebBrowser1.Document = nil do. Application.ProcessMessages; Document := WebBrowser1.Document as IHtmlDocument2; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. V[0] :='<a href="http://ya.ru">Run</a>'; Document.Writeln(PSafeArray(TVarData(v).VArray)); WebBrowser1.OleObject.Document.ParentWindow.Scroll(0, 10000000); End; Procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject; Const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); Begin. If url <> 'about:blank' then. Begin. WebBrowser2.Navigate(URL); Cancel := True; End; End;

Автор: Rouse_

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

©Drkb::03523.

Code: {©Drkb v.3(2007): www.drkb.ru}. Var. NavigateTo: Boolean = False; Procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject; Const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); Begin. If NavigateTo then. Begin. Cancel := True; WebBrowser2.Navigate(URL); End; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. WebBrowser1.Navigate('about:<a href="http://ya.ru">Run</a>'); NavigateTo := True; End;

Автор: s-mike.

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

©Drkb::03524.

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

Code: 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;

©Drkb::03525.

Автор: -TOXA-

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

Редактор диска своими руками.

Редактор диска своими руками

Редактор диска своими руками (v1.05).

Многие помнят легендарный Norton DiskEditor - утилиту, дающую огромный простор для исследовательской и прочей деятельности. И сейчас есть множество аналогов. WinHex, например.

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

Для начала разберемся как происходит само чтение диска. Проще всего это делать в Windows 2000/XP (с правами администратора, конечно). Работа с жестким диском в этих операционных системах производится путем открытия диска как файла с помощью функции CreateFile и указания диска или раздела по схеме Device Namespace (открывается физический диск - '\\.\PHYSICALDRIVE<n>'), полученный хэндл в дальнейшем используется для работы с диском с помощью функций ReadFile, WriteFile и DeviceIoControl.

Code: // Drive - номер диска (нумерация с нуля). HFile := CreateFile(PChar('\\.\PhysicalDrive'+IntToStr(Drive)), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,nil,OPEN_EXISTING,0,0); If hFile = INVALID_HANDLE_VALUE then Exit;

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

Code: Const. IOCTL_DISK_GET_DRIVE_GEOMETRY = $70000; Type. TDiskGeometry = packed record. Cylinders: Int64; // количество цилиндров. MediaType: DWORD; // тип носителя. TracksPerCylinder: DWORD; // дорожек на цилиндре. SectorsPerTrack: DWORD; // секторов на дорожке. BytesPerSector: DWORD; // байт в секторе. End; Result := DeviceIoControl(hFile,IOCTL_DISK_GET_DRIVE_GEOMETRY,nil,0, @DiskGeometry,SizeOf(TDiskGeometry),junk,nil) and (junk = SizeOf(TDiskGeometry));

Функция возвращает True, если операция прошла успешно, и False в противном случае.

Теперь уже можно приступить к определению местоположения логических дисков на винчестере. Начать это нужно с чтения нулевого сектора физического диска. Он содержит MBR (Master Boot Record), а также Partition Table. Кстати, думаю, будет интересно сохранить содержимое MBR в файл и посмотреть программу загрузки каким-нибудь дизасмом. Но в данный момент нас интересует только Partition Table.

Эта таблица располагается в секторе по смещению $1be и состоит из четырех одинаковых элементов, каждый из которых описывает один раздел:

Code: TPartitionTableEntry = packed record. BootIndicator: Byte; // $80, если активный (загрузочный) раздел. StartingHead: Byte; StartingCylAndSect: Word; SystemIndicator: Byte; EndingHead: Byte; EndingCylAndSect: Word; StartingSector: DWORD; // начальный сектор. NumberOfSects: DWORD; // количество секторов. End;

Соответственно, саму Partition Table можно представить как массив:

TPartitionTable = packed array [0..3] of TPartitionTableEntry;

Подробнее остановлюсь на этой структуре. Как видно из описания структур, Partition Table может содержать только четыре раздела. А так как, возможно, пользователю необходимо большее количество, было введено понятие "Extended Partition" (таким образом, разделы бывают Primary и Extended). Extended Partition - это раздел, который имеет свою собственную Partition Table (и, соответственно может содержать в себе еще четыре раздела). Extended Partition содержит логические диски. Тип раздела определяется полем SystemIndicator. Оно содержит информацию о файловой системе логического диска, либо 5 (или $f), если это Extended Partition.

Примеры значений поля SystemIndicator:

01 - FAT12.

04 - FAT16.

05 - EXTENDED.

06 - FAT16.

07 - NTFS.

0B - FAT32.

0F - EXTENDED.

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

Code: // так как диск для нас - это единый файл, то для перемещения по нему. // с помощью SetFilePointer понадобится 64хразрядная арифметика. Function __Mul(a,b: DWORD; var HiDWORD: DWORD): DWORD; // Result = LoDWORD. Asm. Mul edx. Mov [ecx],edx. End; Function ReadSectors(DriveNumber: Byte; StartingSector, SectorCount: DWORD; Buffer: Pointer; BytesPerSector: DWORD = 512): DWORD; Var. HFile: THandle; Br,TmpLo,TmpHi: DWORD; Begin. Result := 0; HFile := CreateFile(PChar('\\.\PhysicalDrive'+IntToStr(DriveNumber)), GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0); If hFile = INVALID_HANDLE_VALUE then Exit; TmpLo := __Mul(StartingSector,BytesPerSector,TmpHi); If SetFilePointer(hFile,TmpLo,@TmpHi,FILE_BEGIN) = TmpLo then. Begin. SectorCount := SectorCount*BytesPerSector; If ReadFile(hFile,Buffer^,SectorCount,br,nil) then Result := br; End; CloseHandle(hFile); End;

И, заодно, функция для записи:

Code: Function WriteSectors(DriveNumber: Byte; StartingSector, SectorCount: DWORD; Buffer: Pointer; BytesPerSector: DWORD = 512): DWORD; Var. HFile: THandle; Bw,TmpLo,TmpHi: DWORD; Begin. Result := 0; HFile := CreateFile(PChar('\\.\PhysicalDrive'+IntToStr(DriveNumber)), GENERIC_WRITE,FILE_SHARE_READ,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0); If hFile = INVALID_HANDLE_VALUE then Exit; TmpLo := __Mul(StartingSector,BytesPerSector,TmpHi); If SetFilePointer(hFile,TmpLo,@TmpHi,FILE_BEGIN) = TmpLo then. Begin. SectorCount := SectorCount*BytesPerSector; If WriteFile(hFile,Buffer^,SectorCount,bw,nil) then Result := bw; End; CloseHandle(hFile); End;

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

Code: PDriveInfo = ^TDriveInfo; TDriveInfo = record. PartitionTable: TPartitionTable; LogicalDrives: array [0..3] of PDriveInfo; End;

Ну а теперь сам код разбора структуры диска:

Code: Const. PartitionTableOffset = $1be; ExtendedPartitions = [5,$f]; Var. MainExPartOffset: DWORD = 0; Function GetDriveInfo(DriveNumber: Byte; DriveInfo: PDriveInfo; StartingSector: DWORD; BytesPerSector: DWORD = 512): Boolean; Var. Buf: array of Byte; CurExPartOffset: DWORD; I: Integer; Begin. SetLength(buf,BytesPerSector); // читаем сектор в буфер. If ReadSectors(DriveNumber,MainExPartOffset+StartingSector,1,@buf[0]) = 0 then. Begin. Result := False; Exit; End; // заполняем структуру DriveInfo.PartitionTable. Move(buf[PartitionTableOffset],DriveInfo.PartitionTable,SizeOf(TPartitionTable)); Finalize(buf); // буфер больше не нужен. Result := True; For i := 0 to 3 do // для каждой записи в Partition Table. If DriveInfo.PartitionTable[i].SystemIndicator in ExtendedPartitions then. Begin. New(DriveInfo.LogicalDrives[I]); If MainExPartOffset = 0 then. Begin. MainExPartOffset := DriveInfo.PartitionTable[I].StartingSector; CurExPartOffset := 0; End else CurExPartOffset := DriveInfo.PartitionTable[I].StartingSector; Result := Result and GetDriveInfo(DriveNumber,DriveInfo.LogicalDrives[I], CurExPartOffset); End else DriveInfo.LogicalDrives[I] := nil; End;

Функция заполняет структуру DriveInfo и возвращает True, если операция прошла успешно, или False в противном случае.

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

В нулевом секторе каждого основного раздела находится BIOS Parameter Block, содержаший такую информацию как название файловой системы, количество секторов в кластере и т.д. А также программа-загрузчик (сохраняем сектор в файл и смотрим дизасмом).

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

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

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

К счастью, в Delphi они уже есть (IntToHex и StrToInt) и остается их только правильно использовать. StrToInt можно использовать для преобразования строки, содержащей шестнадцатиричное число в Integer, если дописать впереди символ $.

Например, StrToInt('$FF');

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

P.S.

Для получения доступа к физическому диску мы открывали устройство \\.\PHYSICALDRIVE<n>, далее разбирали его структуру. Можно было поступить проще - открывать сразу логические диски (\\.\C:,\\.\D: и т.д.), но при таком варианте мы бы упустили из виду некоторые области диска, такие как, MBR и неразмеченные области. Какой вариант предпочтительнее, зависит от задачи.

(с) 2005, Kerk При перепечаке ссылка на сайт http://kladovka.net.ru обязательна.

©Drkb::01386.

Реализация закладки свойств файла.

Реализация закладки свойств файла.

Реализация CallBack вызовов MapInfo.

Автор: Дмитрий Кузан

Реализация Drag-and-Drop из внешнего приложения в ваше

Code: { The following example demonstrates the Drag&Drop machanism from an external. Application (Wordpad, Microsoft,..) to a TMemo in your own application. } Unit TMemoDragDropFrm; { **************************************************************** Source File Name : TMemoDragDropFrm.pas. Typ : Hauptformular. Autor : Andreas Kosch. Compiler : Delphi 4.02 CSS. Betriebssystem : Windows 98. Beschreibung : Text via OLE Drag&Drop ььегnеhmеn aus einer. Anderen Anwendung (wie zum Beispiel WordPad). Ььегnеhmеn. 16.01.2003: Test mit Delphi 7 und Microsoft Word XP unter Windowx XP. **************************************************************** } { Comments by Thomas Stutz }. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls; Type. // TForm1's declaration indicates that it's a TForm and that. // it supports the IDropTarget interface: { IDropTarget. Any application wanting to accept drop operations must. Implement the IDropTarget interface. Methods of the IDropTarget interface: DragEnter. Dragged item has just been moved into the application's window, Return the relevant icon. DragOver. Dragged item is being moved over the application's window, Return the relevant icon. DragLeave. Dragged item has just moved out of the application's window. Drop. The dragged item has been dropped on this application. } TForm1 = class(TForm, IDropTarget). Memo1: TMemo; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. // IDropTarget. Function DragEnter(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; stdcall; Function DragOver(grfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; stdcall; Function DragLeave: HResult; stdcall; Function Drop(const dataObj: IDataObject; GrfKeyState: Longint; pt: TPoint; Var dwEffect: Longint): HResult; stdcall; // IUnknown. // Ignore referance counting. Function _AddRef: Integer; stdcall; Function _Release: Integer; stdcall; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses. ShellAPI; // In the OnCreate event handler, two important methods are called. // First, OleInitalize is called. This initializes the OLE libraries and should always be. // called before your application uses any OLE functions. // RegisterDragDrop registers the window as a valid drop target. // If this isn't called, the window will never receive any drop events. Procedure TForm1.FormCreate(Sender: TObject); Begin. OleInitialize(nil); {Allow window to accept drop events}. OleCheck(RegisterDragDrop(Handle, Self)); { Execute Wordpad for testing }. ShellExecute(Handle, 'open', 'wordpad', 'c:\Test.doc', nil, SW_SHOW); End; // OnDestroy does the exact opposite. It calls RevokeDropTarget to indicate that. // drop events are no longer accepted. // It then calls OleUninitialize, since the application is finished using all OLE functions. Procedure TForm1.FormDestroy(Sender: TObject); Begin. {Finished accepting drops}. RevokeDragDrop(Handle); OleUninitialize; End; {-----------------------------------------------------------------} { IDropTarget-Implementierung }. {-----------------------------------------------------------------} Function TForm1.DragEnter(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Begin. DwEffect := DROPEFFECT_COPY; Result := S_OK; End; Function TForm1.DragOver(grfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Begin. DwEffect := DROPEFFECT_COPY; Result := S_OK; End; Function TForm1.DragLeave: HResult; Begin. Result := S_OK; End; Function TForm1._AddRef: Integer; Begin. Result := 1; End; Function TForm1._Release: Integer; Begin. Result := 1; End; Function TForm1.Drop(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Var. AFmtEtc: TFORMATETC; AStgMed: TSTGMEDIUM; PData: PChar; Begin. {Make certain the data rendering is available}. If (dataObj = nil) then. Raise Exception.Create('IDataObject-Pointer is not valid!'); With aFmtEtc do. Begin. CfFormat := CF_TEXT; Ptd := nil; DwAspect := DVASPECT_CONTENT; Lindex := -1; Tymed := TYMED_HGLOBAL; End; {Get the data}. OleCheck(dataObj.GetData(aFmtEtc, aStgMed)); Try. {Lock the global memory handle to get a pointer to the data}. PData := GlobalLock(aStgMed.hGlobal); { Replace Text }. Memo1.Text := pData; Finally. {Finished with the pointer}. GlobalUnlock(aStgMed.hGlobal); {Free the memory}. ReleaseStgMedium(aStgMed); End; Result := S_OK; End; End.

Реализация односвязного и двусвязного списков

Реализация односвязного и двусвязного списков

По изданию "Модели и структуры данных" Alexander S. Derevjanko.

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

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

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

· любая структура информационной части списка:

Code: Type data = ...;

Реализация протоколов.

Реализация протоколов

10. Реализация протоколов.

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

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

1. Стандартный – эти протоколы относятся к Интернет стандартам. Для понимания просто найдите в RFC нужный протокол. В RFC протокол рассмотрен в подробностях.

2. Пользовательский – пользовательские протоколы используются, когда отсутствует нужный протокол. Создание пользовательского протокола будет описано позже.

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

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

Первым шагом построения клиента или сервера – это понять протокол. Для стандартных протоколов это может быть сделано с помощью чтения RFC. Для пользовательских протоколов вы его должны сами разработать.

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

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

· 1xx - информационные

· 2xx - успешные

· 3xx – временные ошибки

· 4xx – постоянные ошибки

· 5xx – внутренние ошибки

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

10.1. Терминология протокола.

Перед обсуждением реализации протокола рассмотрим некоторые термины.

10.1.1. Простой текст (plain text).

Простой текст (plain text) означает, что все команды (commands) и ответы (replies) используют только 7-битный код ASCII. Если передача данных в откликах (responses) допустима в двоичном виде, то почти все команды протокола и ответы используют простой текст. Двоичный код никогда не должен использоваться в командах и ответах, если на это не будет веских оснований.

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

10.1.2. Команды (commands).

Команда это текстовая строка, которая посылается клиентом серверу для запроса информации или выполнения определенных действий. Примеры команд: HELP, QUIT, LIST.

Команды могут содержать дополнительные параметры, разделенные пробелами.

Пример:

GET CHARTS.DAT.

GET - это команда, а CHARTS.DAT – это параметр. В данном примере используется только один параметр, но команды могут содержать несколько параметров. Обычно параметры разделены пробелами, аналогично параметрам в DOS или в командной строке.

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

Один из плохих примеров последствий локализации команд, является Microsoft Office. Microsoft Office может быть автоматизирован, с помощью OLE. Тем не менее, Microsoft локализовал имена методов и свойств объектов. Это означает, что если вы пишите приложения с помощью Microsoft Office Automation в американской версии, то ваше приложение не будет работать во французской версии.

10.1.3. Ответы (reply).

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

Например, если команда GET customer.dat, вернет ответ 200 OK, это будет означать, что команда воспринята и будет обработана. Ответы обычно состоят только из одной строки, но могут состоять и из нескольких строк.

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

10.1.4. Отклики (response).

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

Отклики могут быть текстовыми или двоичными. Если отклик текстовый, то обычно этот отклик в формате RFC откликов.

10.1.5 Переговоры (conversations).

Большинство протоколов аналогичны переговорам. Некоторые очень просты, а некоторые нет, но обычно они все равно в простом текстовом формате.

Переговоры означают следующую структуру:

1. отправка команды

2. возврат состояния

3. дополнительные данные отклика

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

Client: lookup 37642 77056.

Server: 200 Ok.

Server: 37642: CHURCH HILL, TN.

Server: 77056: HOUSTON, TX.

Server: .

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

Команда:

Client: lookup 37642 77056.

Ответ:

Server: 200 Ok.

Отклик:

Server: 37642: CHURCH HILL, TN.

Server: 77056: HOUSTON, TX.

Server: .

Каждая из этих частей будет объяснена ниже.

10.2 RFC - определения.

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

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

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

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

10.2.1. RFC - коды состояния.

Коды состояния RFC имеют следующую форму:

XXX Status Text.

Где XXX это цифровой код в диапазоне 100-599.

Трехзначный цифровой номер означает ответ, который в ран-тайм, служит для определения результата выполнения команды. Обычно присутствует дополнительный текст, показываемый пользователю или для отладки. В этом случае, обычно используется английский язык, но может быть и локализован, если будет удовлетворять 7-битному коду ASCII. В некоторых случаях, когда данные короткие, данные возвращаются в дополнительном текстовом поле. В этих случаях данные все рано должны быть 7-бит ASCII, но протокол сам определяет язык и ограничения форматов. В большинстве случаев, эти данные языко-независимы (language neutral). Например, команда "TIME", возвращает "15:30" в дополнительном текстовом поле.

Пример RFC ответа:

404 No file exists.

404 это цифровой отклик и "No file exists" это дополнительное текстовое сообщение. Только код 404 должен быть интерпретирован программой и код 404 должен быть точно определен протоколом именно для этого. Текстовое сообщение обычно используется для отладки, ведения логов или для показа пользователю. Текстовое сообщение может иметь различные формы, от реализации к реализации и может быть локализировано на другие языки. Языки которые не соответствуют требованиям кода 7-бит ASCII должны быть транслитеризированы в английские символы.

Цифровая часть может быть назначена любым значениям. Тем не менее существует общее соглашение:

· 1xx - информационные

· 2xx - успешные

· 3xx – временные ошибки

· 4xx – постоянные ошибки

· 5xx – внутренние ошибки

Числа обычно уникальные, но не всегда. Если вы назначите 201 для "File not found", многие команды могут отвечать этим кодом и значение всегда одно. В некоторых редких случаях, значение числа зависит от примененной команды. В этом случае, каждая команда назначает специфическое значение each command assigns specific meanings to each numeric reply.

Цифровые коды, заканчивающие на 00, то есть 100, 200, и так далее резервированы для общих ответов, которые не имеют специального значения связанного с ними. 200 наиболее часто с "Ok".

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

Пример такого ответа:

400-Unknown Error in critical system.

400-The server encountered an error and has no clue what caused it.

400-Please contact Microsoft technical support, or your local.

400-tarot card reader who may be more helpful.

400 Thank you for using our products!

10.2.1.1. Примеры.

Здесь пример некоторых кодов состояния, полученные от HTTP протокола. Как вы видите они относятся к разным категориям по первой цифре.

200 Ok.

302 Redirect.

404 Page not found.

500 Internal Error.

Если вы видите 500 Internal Error, велик шанс, что вы используете Microsoft IIS. (Грубый наезд :-)).

10.2.2. RFC – ответ (reply).

RFC ответ, возвращает код состояния.

10.2.3. RFC – отклик (response).

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

RFC отклики очень применимы, когда заранее неизвестно количество возвращаемых данных. Это используется в HTTP, Mail, News и других протоколах.

Методы Indy, которые поддерживают RFC отклики – это Capture (для приема) и WriteStrings (для передачи).

10.2.4. RFC - транзакции.

Транзакция RFC это общение, которое состоит из команды, ответа и дополнительного отклика, все в формате RFC. Обработчики команд и другие части Indy построены на транзакциях RFC.

Примет транзакции:

GET File.txt.

201 File follows.

Hello,

Thank you for your request, however we cannot grant your.

Request for funds for researching as you put it in your.

Application "A better mouse trap".

Thank you, and please do not give up.

.

10.3. Класс TIdRFCReply.

TIdRFCReply обладает возможностью посылки и приема RFC ответов. TIdRFCReply имеет три основных свойства: NumericCode, Text и TextCode. NumericCode и TextCode взаимно исключающие. TextCode – свойство, которое управляет такими протоколами, как POP3 и IMAP4.

Для генерации ответа, установите свойство NumericCode (или TextCode) и дополнительно введите текст в свойство Text. Свойство Text типа TStrings позволяет многострочные ответы.

TIdRFCReply имеет методы для записи форматированных ответов, и также для разбора текста в TIdRFCReply.

TIdRFCReply используется для посылки ответов на команды, и также для свойств ReplyException, ReplyUnknown и Greeting properties класса TIdTCPServer.

10.4. Класс ReplyTexts.

Цифровой код в ответе обычно уникален для каждой ошибки. Например, протокол HTTP использует код 404 для "Resource not found". Многим командам разрешено возвращать код 404 как ошибку, но код 404 всегда должен означать одну и туже ошибку. Для преодоления дублирования текстов для ошибки 404 класс TIdTCPServer имеет свойство ReplyTexts.

Свойство ReplyTexts – это коллекция экземпляров TIdRFCReply, которые могут быть обработаны, как в ран-тайм, так и в дизайн-тайм. Свойство ReplyTexts используется для обработки списка текстов, которые связаны с цифровым кодом. Когда свойство TIdRFCReply используется в TCPServer, который имеет цифровой код, но не имеет текстовой части, Indy просматривает в ReplyTexts и использует строку от туда.

Вместо включения текста, в каждый ответ 404 посмотрите ниже:

ASender.Reply.SetReply(404, 'Resource Not Found');

Затем может использоваться следующий код:

ASender.Reply.NumericCode := 404;

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

10.5. Курица или яйцо?

При построении системы, в которой вы должны построить, и сервер, и клиента, возникает следующий вопрос - "что делать сначала, клиента или сервера?". Оба нужны одновременно для отладки.

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

Для тестирования, подсоединитесь к серверу на его порт. В командной строке введите:

Telnet newsgroups.borland.com 119.

Теперь нажмите клавишу enter.

На Windows 95/98/ME и NT это может выглядеть немного иначе, чем на Windows 2000 или на Windows XP, но результат должен быть таким же. Другие версии Windows загружают телнет, как новое приложение в свом окне. Выше показанный рисунок относится к Windows XP', в котором телнет является консольным приложением.

Команда "Telnet newsgroups.borland.com 119" указывает клиенту телнета, подсоединиться к newsgroups.borland.com на порт 119. Порт 119 используется для протокола NNTP (News). Подобно подсоединения к серверу новостей Borland, телнет может использоваться для соединения с любым сервером, использующим текстовый протокол.

Для отсоединения от сервера новостей введите команду "Quit" и нажмите enter.

10.6. Определение пользовательского протокола.

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

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

При определении протокола, должны быть сделаны следующие решения:

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

· TCP или UDP? Это определяется от требований к протоколу. Изучите все характеристики и решите с осторожностью. В большинстве случаев TCP правильный выбор.

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

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

10.7. Симуляция другой стороны (Peer Simulation).

Традиционно естественный путь построения клиента и сервера – это сначала построение сервера, а затем клиента или построения их параллельно. Но Indy имеет возможность построить клиент или сервер, отдельно друг от друга. В некоторых случаях, один может быть построен без необходимости доступа к другому. В таких случаях может использоваться эмуляция (видимо симуляция, судя по названию главы) другой стороны. Эмуляция другой стороны будет обсуждена позже в главе 14. Отладка.

10.8. Протокол получения почтового кода.

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

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

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

Для тех, кто находится за пределами Соединенных Штатов Америки и не знаком с их системой, zip это почтовый код в США, который указывает регион доставки. Zip коды цифровые и состоят из 5 цифр. Zip коды могут также содержать дополнительные четыре цифры в формате 16412-0312. Данный тип кодов получил название Zip+4. Четыре дополнительные цифры уточняют локальную зону доставки и не требуются для определения города.

При создании протокола были приняты следующие решения:

· Все команды текстовые

· Транспорт TCP

· Порты: 6000. Порт 6000 это наиболее часто используемый номер в тестовых примерах Indy. Это не имеет значения.

Протокол поддерживает следующие команды.

· Help – получение справки

· Lookup <почтовый код 1> < почтовый код 2> ... – запрос информации

· Quit – отсоединение от сервера

При разработке протокола, полезно знать ключевые протоколы, такие как - NNTP, SMTP и HTTP и использовать их как модель. Исключая POP3 и IMAP4. Поскольку это плохой пример построения протоколов.

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

10.8.1. Команда Help.

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

Команда Help полезна для вывода справки о командах сервера и их возможном применении.

Вот пример ответа Борландовского сервера новостей сервера, на команду HELP:

Help.

100 Legal commands.

Authinfo user Name|pass Password.

Article [MessageID|Number].

Body [MessageID|Number].

Check MessageID.

Date.

Group newsgroup.

Head [MessageID|Number].

Help.

Ihave.

Last.

List [active|active.times|newsgroups|subscriptions].

Listgroup newsgroup.

Mode stream.

Mode reader.

Newgroups yymmdd hhmmss [GMT] [<distributions>].

Newnews newsgroups yymmdd hhmmss [GMT] [<distributions>].

Next.

Post.

Slave.

Stat [MessageID|Number].

Takethis MessageID.

Xgtitle [group_pattern].

Xhdr header [range|MessageID].

Xover [range].

Xpat header range|MessageID pat [morepat...].

.

Для нашего протокола, сервер отвечает кодом 100, плюс сопроводительный текст.

10.8.2. Команда Lookup.

Команда lookup принимает один или несколько почтовых кодов для поиска и возвращает название города и штат. Данные возвращаются в формате RFC откликов. Если код не найден, то отклик не возвращается (но если судить по примеру это не так, возвращает пустой отклик – строка с точкой). Код ответа "200 Ok".

Пример:

Lookup 37642 16412.

200 Ok.

37642: CHURCH HILL, TN.

16412: EDINBORO, PA.

.

Даже если код не найден, то возвращается ответ "200 Ok".

Lookup 99999.

200 Ok.

.

Мы приняли такое решение. Если бы сервер мог воспринимать только один параметр, то можно бы было отвечать кодом 200, и если не найден, то кодом 4XX. Но протокол может возвращать часть для правильных данных, поэтому было решено всегда возвращать код 200.

При частично правильных данных и ответ:

Lookup 37642 99999.

200 Ok.

37642: CHURCH HILL, TN.

.

Если бы протокол возвращал код ошибки, то частичные данные были бы проигнорированы. Данное решение позволило серверу отвечать и на частично правильные запросы, без генерации ошибки.

10.8.3. Команда Quit.

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

Посмотрим снова на сервер новостей Борланда. Его ответ следующий:

Quit.

205 closing connection - goodbye!

The postal code protocol responds similarly:

Quit.

201-Paka! (Russians are everywhere J).

201 2 requests processed.

Почтовый протокол выдает многострочные ответы. Это не определено самим протоколом. Любые RFC ответы могут быть как однострочными, так и многострочными. Indy обрабатывает оба типа ответов автоматически.

Реализация функции Delay.

Режим вставки и замены

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

Регионарные стандарты

В Дельфи есть предопределенные переменные языковых установок и форматов:

Code: // SysUtils. Var CurrencyString: string; Var CurrencyFormat: Byte; Var NegCurrFormat: Byte; Var ThousandSeparator: Char; Var DecimalSeparator: Char; Var CurrencyDecimals: Byte; Var DateSeparator: Char; Var ShortDateFormat: string; Var LongDateFormat: string; Var TimeSeparator: Char; Var TimeAMString: string; Var TimePMString: string; Var ShortTimeFormat: string; Var LongTimeFormat: string; Var ShortMonthNames: array[1..12] of string; Var LongMonthNames: array[1..12] of string; Var ShortDayNames: array[1..7] of string; Var LongDayNames: array[1..7] of string; Var SysLocale: TSysLocale; Var EraNames: array[1..7] of string; Var EraYearOffsets: array[1..7] of Integer; Var TwoDigitYearCenturyWindow: Word = 50; Var TListSeparator: Char;

Регистрация программ в меню Пуск Windows95.

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов - объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:

Code: Function TForm2.ProgmanCommand(Command: string): boolean; Var. Macrocmd: array[0..88] of char; Begin. DDEClient.SetLink('PROGMAN', 'PROGMAN'); DDEClient.OpenLink; { Устанавливаем связь по DDE }. StrPCopy(macrocmd, '[' + Command + ']'); { Подготавливаем ASCIIZ строку }. ProgmanCommand := DDEClient.ExecuteMacro(MacroCmd, false); DDEClient.CloseLink; { Закрываем связь по DDE }. End; // Пример использования: ProgmanCommand('CreateGroup(Комплекс программ для. Каталогизации литературы, )'); ProgmanCommand('AddItem(' + path + 'vbase.hlp, Справка по VBase, '+ path +' vbase.hlp, 0, , , '+ path + ', , )'); // где path - строка типа String, содержащая. // полный путь к каталогу ('C:\Catalog\');

Решение СЛАУ, вычисление обратных матриц и определителей с использованием LU-разложения

Code: Unit LU_Utils; Interface. Uses Classes; Type. TDblArr = array of Double; TIntArr = array of Integer; TDblMatr = array of array of Double; Procedure CopyMatr(Src, Dest: TDblMatr); //исходная матрица разрушается, при необходимости нужно сделать копию. Procedure LUDecomp(Matr: TDblMatr; Indx: TIntArr; var DSign: Integer); Procedure LUBackSubst(Matr: TDblMatr; Indx: TIntArr; Reslt: TDblArr); //решение системы линейных уравнений. XY на входе - правые части, //на выходе - вектор решений. //LU-разложение матрицы может использоваться многократно с. //разными правыми частями (при модификации кода). Procedure SLAUSolver(Matr: TDblMatr; XY: TDblArr); //исходная матрица заменяется обратной. Procedure MatrInverse(Matr: TDblMatr); //исходная матрица сохраняется. Function Determinant(Matr: TDblMatr): Double; Implementation. Uses SysUtils; Procedure CopyMatr(Src, Dest: TDblMatr); Var. N, i: Integer; Begin. N := Length(Src); For i := 0 to n - 1 do. Move(Src[i, 0], Dest[i, 0], n * SizeOf(Double)); End; Procedure LUDecomp(Matr: TDblMatr; Indx: TIntArr; var DSign: Integer); Const. Tiny = 1.0E-40; Var. N, k, j, imax, i: Integer; Sum, dum, big: Double; VV: TDblArr; DumPtr: Pointer; Begin. N := Length(Matr); SetLength(VV, n); DSign := 1; For i := 0 to n - 1 do begin. Big := 0; For j := 0 to n - 1 do. If (abs(Matr[i, j]) > big) then. Big := Abs(Matr[i, j]); If (big = 0.0) then. Raise Exception.Create('Stopped. Matrix is singular!!!'); VV[i] := 1 / big; End; For j := 0 to n - 1 do begin. For i := 0 to j - 1 do begin. Sum := Matr[i, j]; For k := 0 to i - 1 do. Sum := sum - Matr[i, k] * Matr[k, j]; Matr[i, j] := sum; End; Big := 0; For i := j to n - 1 do begin. Sum := Matr[i, j]; For k := 0 to j - 1 do. Sum := sum - Matr[i, k] * Matr[k, j]; Matr[i, j] := sum; Dum := VV[i] * abs(sum); If (dum > big) then begin. Big := dum; Imax := i; End; End; If (j <> imax) then begin. DumPtr := Pointer(Matr[imax]); Pointer(Matr[imax]) := Pointer(Matr[j]); Pointer(Matr[j]) := DumPtr; DSign := -DSign; VV[imax] := VV[j]. End; Indx[j] := imax; If (Matr[j, j] = 0) then. Matr[j, j] := Tiny; If (j <> n - 1) then begin. Dum := 1 / Matr[j, j]; For i := j + 1 to n - 1 do. Matr[i, j] := Matr[i, j] * dum; End; End; End; Procedure LUBackSubst(Matr: TDblMatr; Indx: TIntArr; Reslt: TDblArr); Var. N, j, ip, ii, i: Integer; Sum: Double; Begin. N := Length(Matr); Ii := -1; For i := 0 to n - 1 do begin. Ip := Indx[i]; Sum := Reslt[ip]; Reslt[ip] := Reslt[i]; If (ii <> -1) then. For j := ii to i - 1 do. Sum := sum - Matr[i, j] * Reslt[j]. Else. If (sum <> 0.0) then. Ii := i; Reslt[i] := sum; End; For i := n - 1 downto 0 do begin. Sum := Reslt[i]; If (i < n - 1) then. For j := i + 1 to n - 1 do. Sum := sum - Matr[i, j] * Reslt[j]; Reslt[i] := sum / Matr[i, i]; End. End; Procedure SLAUSolver(Matr: TDblMatr; XY: TDblArr); Var. Indx: TIntArr; DSign: Integer; Begin. SetLength(Indx, Length(XY)); LUDecomp(Matr, Indx, DSign); LUBackSubst(Matr, Indx, XY); End; Procedure MatrInverse(Matr: TDblMatr); Var. N, i, j: Integer; Indx: TIntArr; Col: TDblArr; DSign: Integer; Temp: TDblMatr; Begin. N := Length(Matr); SetLength(Indx, n); SetLength(Col, n); SetLength(Temp, n, n); LUDecomp(Matr, Indx, DSign); For j := 0 to n - 1 do begin. For i := 0 to n - 1 do. Col[i] := 0; Col[j] := 1; LUBackSubst(Matr, Indx, Col); For i := 0 to n - 1 do. Temp[i, j] := Col[i]; End; CopyMatr(Temp, Matr); Temp := nil; End; Function Determinant(Matr: TDblMatr): Double; Var. N, j: Integer; Indx: TIntArr; DSign: Integer; Temp: TDblMatr; Begin. N := Length(Matr); SetLength(Indx, n); SetLength(Temp, n, n); CopyMatr(Matr, Temp); LUDecomp(Temp, Indx, DSign); Result := DSign; For j := 0 to n - 1 do. Result := Result * Temp[j, j]; End; End.

Работа с ячейкой листа Microsoft Excel.

Работа с ячейкой листа Microsoft Excel.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Работа с ячейкой листа Microsoft Excel. Получает и заносит число типа double в ячейку листа Microsoft Excel. Зависимости: ComObj. Автор: lookin, lookin@mail.ru, Екатеринбург. Copyright: lookin. Дата: 30 апреля 2002 г. ********************************************** } //ВНИМАНИЕ: ОБЯЗАТЕЛЬНОЕ условие работы - наличие запущенного Excel. //получение double из заданной ячейки первого листа в заданной рабочей книге. Function DoubleValueFromExcelCell(ExcelWorkBook,ExcelCell: string): double; Var i: integer; Excel,v: Variant; Begin. Excel:=GetActiveOleObject('Excel.Application'); For i:=1 to Excel.Application.Workbooks.Count do. If Excel.Application.Workbooks[i].FullName=ExcelWorkBook then begin. V:=Excel.Application.Workbooks[i].Sheets[1].Range[ExcelCell]; DoubleValueFromExcelCell:=VarAsType(v,varDouble); v:=0; Excel:=0; end; End; //занесение double в заданную ячейку первого листа в заданной рабочей книге. Procedure DoubleValueToExcelCell(Value: double; ExcelWorkBook,ExcelCell: string); Var i: integer; Excel,v: Variant; Begin. Excel:=GetActiveOleObject('Excel.Application'); For i:=1 to Excel.Application.Workbooks.Count do. If Excel.Application.Workbooks[i].FullName=ExcelWorkBook then begin. Excel.Application.EditDirectlyInCell:=false; v:=Value; Excel.Application.Workbooks[i].Sheets[1].Range[ExcelCell]:=v; end; End;

©Drkb::04404.

Работа с ассоциациями файла.

Работа с ассоциациями файла

Code: Unit Associations; { Subset }. Interface. Procedure RegisterFiletype( Const extension, filetype, description, Verb: String; params: String ); Procedure RegisterFileIcon( Const filetype, iconsource: String; Iconindex: Cardinal ); Function FiletypeIsRegistered( Const extension, filetype: String ): Boolean; Implementation. Uses Windows, Classes, SysUtils, Registry; ResourceString. ECannotCreateKey = 'Cannot create key %s, the user account may not have the required '+ 'rights to create registry keys under HKEY_CLASSES_ROOT.'; Type. ERegistryError = Class( Exception ); {+------------------------------------------------------------ | Procedure CreateKey. | | Visibility : restricted to unit. | Description: | This is a helper function which uses the passed reg object. | to create a registry key. | Error Conditions: | If the key cannot be created a ERegistryError exception is. | raised. | Created: 14.03.99 by P. Below. +------------------------------------------------------------} Procedure CreateKey( reg: TRegistry; Const keyname: String ); Begin. If not reg.OpenKey( keyname, True ) Then. Raise ERegistryError.CreateFmt( eCannotCreateKey, [keyname] ); End; { CreateKey }. {+------------------------------------------------------------ | Procedure InternalRegisterFiletype. | | Parameters : | extension : file extension, including the dot, to register. | filetype : string to use as key for the file extension. | description: string to show in Explorer for files with this. | extension. If description is empty the file. | type will not show up in Explorers list of. | registered associations! | verb : action to register, 'open', 'edit', 'print' etc. | The action will turn up as entry in the files. | context menu in Explorer. | serverapp : full pathname of the executable to associate with. | the file extension, including any command line. | switches. Include the "%1" placeholder as well. | Actions like printto may require more than one. | placeholder. | Visibility : restricted to unit. | Description: | Creates the three basic registry keys for a file extension. | HKCR\<extension> = <filetype> | HKCR\<filetype> = <description> | HKCR\<filetype>\shell\<verb>\command = <serverapp> | If the keys already exist they are overwritten! | Error Conditions: | A ERegistryError exception will result if a key cannot be. | created. Failure to create a key is usually due to insufficient. | user rights and only a problem on NT. | Created: 14.03.99 by P. Below. +------------------------------------------------------------} Procedure InternalRegisterFiletype( Const extension, filetype, Description, Verb, serverapp: String ); Var. Reg: TRegistry; Keystring: String; Begin. Reg:= TRegistry.Create; Try. Reg.Rootkey := HKEY_CLASSES_ROOT; CreateKey( reg, extension ); Reg.WriteString( '', filetype ); Reg.CloseKey; CreateKey( reg, filetype ); Reg.WriteString('', description ); Reg.closekey; Keystring := Format('%s\shell\%s\command', [filetype, verb] ); CreateKey( reg, keystring ); Reg.WriteString( '', serverapp); Reg.CloseKey; Finally. Reg.free; End; End; { InternalRegisterFiletype }. {+------------------------------------------------------------ [OBJECT]. | Procedure RegisterFiletype. [OBJECT]. | | Parameters : | extension : file extension, including the dot, to register. | filetype : string to use as key for the file extension. | description: string to show in Explorer for files with this. | extension. If description is empty the file. | type will not show up in Explorers list of. | registered associations! | verb : action to register, 'open', 'edit', 'print' etc. | The action will turn up as entry in the files. | context menu in Explorer. | params : The command line parameters to pass to the. | app when a file action is requested. If this. | parameter is empty "%1" is used by default. | Visibility : exported from unit. | Description: | Builds the commandline to use from the applications filename. | and the passed params and hands the rest of the work off to. | InternalRegisterFiletype. | Error Conditions: none. | Created: 20.03.99 by P. Below. +------------------------------------------------------------} Procedure RegisterFiletype( Const extension, filetype, description, Verb: String; params: String ); Begin. If Length(params) = 0 Then. Params := '"%1"'; InternalRegisterFiletype( Extension, filetype, description, verb, ParamStr(0) + ' ' + params ); End; { RegisterFiletype }. {+------------------------------------------------------------ | Procedure RegisterFileIcon. | | Parameters : | filetype : file type key name to register the icon for. | iconsource: full pathname of the executable or ICO file. | that contains the icon. | iconindex : index of the icon to use, if several are containd. | in iconsource. Counts from 0! | Visibility : exported from unit. | Description: | Creates the registry keys required to tell Explorer which icon. | to display for files of this type. RegisterFileType needs. | to be called first to associate the filetype with an extension. | The registry key added is. | HKCR\<filetype>\DefaultIcon = <iconsource>,<iconindex> | If the key already exists it is overwritten! | The icon specified should contain both large (32*32) and small. | (16*16) versions of the icon, to optain optimal display. | quality. If only one icon format is present Windows will. | generate the other from it. | Error Conditions: | A ERegistryError exception will result if a key cannot be. | created. Failure to create a key is usually due to insufficient. | user rights and only a problem on NT. | Error Conditions: none. | Created: 21.03.99 by P. Below. +------------------------------------------------------------} Procedure RegisterFileIcon( Const filetype, iconsource: String; Iconindex: Cardinal ); Var. Reg: TRegistry; Keystring: String; Begin. Reg:= TRegistry.Create; Try. Reg.Rootkey := HKEY_CLASSES_ROOT; Keystring := Format( '%s\DefaultIcon',[filetype] ); CreateKey( reg, keystring ); Reg.WriteString( '', Format( '%s,%d', [iconsource,iconindex] )); Reg.CloseKey; Finally. Reg.free; End; End; { RegisterFileIcon }. {+------------------------------------------------------------ [OBJECT]. | Function FiletypeIsRegistered. [OBJECT]. | | Parameters : | extension : file extension, including the dot, to search for. | filetype : string to use as key for the file extension. | Returns : True if this application is registered as server. | for the 'open' action, false otherwise. | Visibility : exported from unit. | Description: | Checks if there is a registry entry for the passed extension, | if it is associated with the expected file type and if this. | application is registered as server for the 'open' action. | Error Conditions: none. | Created: 21.03.99 by P. Below. +------------------------------------------------------------} Function FiletypeIsRegistered( Const extension, filetype: String ): Boolean; Var. Reg: TRegistry; Keystring: String; Begin. Result := False; Reg:= TRegistry.Create; Try. Reg.Rootkey := HKEY_CLASSES_ROOT; If reg.OpenKey(extension, false) Then Begin. { Extension is registered, check filetype }. Keystring := reg.ReadString(''); Reg.Closekey; If CompareText( keystring, filetype) = 0 Then Begin. { Filetype is registered for this extension, check server. }. Keystring := Format( '%s\shell\open\command',[filetype] ); If reg.OpenKey( keystring, false ) Then Begin. { Command key exists, but is this app the server? }. Keystring := UpperCase( reg.ReadString('')); Reg.CloseKey; If Pos( UpperCase(ParamStr(0)), keystring ) = 1 Then Begin. { Yes, server matches! }. Result := True; End; { If }. End; { If }. End; { If }. End; { If }. Finally. Reg.free; End; End; { FiletypeIsRegistered }. End { Unit Associations }.

©Drkb::01743.