Hello, MiniProg

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Иванов Петр ака Brodia@a

Специально для Королевства Delphi

Я не знаю, к какой области «Королевства» отнести эту статью. В принципе, данная публикация подготавливалась для раздела «Hello, World».

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

Первоначальная идея была проста, написать несложную программу, исходный текст которой можно было бы использовать как некий шаблон, с реализованной функциональностью, отвечающей наиболее часто выдвигаемым требованиям. Следует помнить о данной публикации то, что она навеяна темой форума «Delphi Kingdom VCL :)».

Желающие могут присоединиться: покритиковать, дополнить, исправить; и если изменения или найденные ошибки будут существенны, то будет написана новая статья.

Начнем, с требований, которым должна соответствовать программа:

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

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

3. Интерфейс — SDI (MDI хорош для приложений вроде Word или Exceel).

4. Желательно предусмотреть возможность масштабирования размеров окон, а также размеров и положения всех визуальных элементов, расположенных на ней, после изменения размеров экранного шрифта. Размеры окон и визуальных компонентов не должны меняться при изменении разрешения экрана.

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

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

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

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

9. Управляющие ключи командной строки, должны поддерживать, как минимум ключ «?» и/или «help»- вывод краткого пояснения о программе, и подсказки о доступных ключах, в режиме консоли. Ключ «concole» — запуск в режиме консоли. Ключ «nologo» — отключение показа заставки. Ключ «logo » c параметром, определяющим время показа заставки.

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

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

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

Ну что же, первый шаг, создание директории проекта, назовем его MiniProg, в которой расположим поддиректории:

DCU — откомпилированные dcu (такова моя привычка :),

DOC — поместим текст данной статьи,

DUNIT — система автоматического тестирования от SourceForge,

IMAGE — для картинок и иконок,

SOURCE — исходные тексты самой программы,

TEST — исходные тексты тестирующих файлов.

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

Создаем проект, главную форму называем просто и незатейливо — FMain. Cохраняем как файл Main.pas в поддиректории SOURCE. Проект сохраняем как MiniProg.dpr, там же :). Открываем меню Project | Options, переходим на страницу Directories/Conditionals, заносим в Output directory и в Unit output directory соответствующие пути. В нашем случай это будут «..\..\MiniProg» и «..\..\MiniProg\DCU». Можно и короче записать, но так нагляднее. Если есть иконка для программы, то устанавливаем её на странице Application, через Load Icon. Создадим новый unit, сохраним под именем Appl.pas. Зачем? Как задел на будущее, будем размещать в нем функции и процедуры, реализующие наши требования.

Теперь начнем выполнять пункт 2 наших требований, т.е. создавать тестирующую программу. В подкаталоге DUNIT расположены некоторые необходимые нам файлы, взятые из оригинального DUNIT , версии от 2002/01/17. И так, создаем новый проект, закрываем Unit1.pas, отказываемся от сохранения, проект назовем, без особой фантазии, testMiniProg.dpr и сохраняем в TEST. Удаляем всё из этого файла и помещаем в него такой код:

program testMiniProg;

uses

Forms,

TestFrameWork,

GUITestRunner;

{$R *.res}

begin

Application.Initialize;

GUITestRunner.RunRegisteredTests;

end.

В настройках проекта, на странице Directories/Conditionals, заполняем поля Output directory и Unit output directory, так же, как и у проекта MiniProg. Дополнительно пропишем в Search path поддиректорий SOURCE и DUNIT. Вот теперь, можно создать новый unit с названием (как бы вы думали?) testAppl.pas и следующим содержанием:

unit testAppl;

interface

uses

TestFramework, SysUtils, Controls, Forms, Appl;

type

TTestUnitAppl = class(TTestCase)

published

end;

implementation

initialization

TestFramework.RegisterTest(TTestUnitAppl.Suite);

end.

Можно откомпилировать testMiniProg и посмотреть на внешний вид нашей тестирующей программы. В дереве просмотра, с именем Test Hierarchy, будут заноситься наши тесты, серые квадратики, при успешном прохождении теста, будут окрашиваться зеленым цветов, иначе — красным или розовым (цвет может быть и синим). Тесты можно отключать галочками. В окнах, расположенных ниже, можно будет наблюдать сообщение о всякой всячине, в том числе и некоторое пояснение о крахе теста. Да, кстати, тесты запускаются кнопочкой, с изображением зеленого треугольника, но пока он окрашен в серый цвет, так как ни одного реального теста у нас нет. Вот, вкратце и всё, что пока нужно знать о DUNIT. Товарищи, желающие узнать о DUNIT больше, а так же патологические «ХочуВсёЗнайки», могут самостоятельно поискать дополнительную информацию. Хочу только заметить, что данная система проверки является портом с JUNIT, и создавалась для применения в проектах с использованием Xtreem Programming (сокращенно XP). Одной из отличительных особенностей данной

методологии является глубокая неприязнь к ведению документации :). Подробнее и по-русски можно посмотреть здесь , там же приведены ссылки по этой тематике. Конечно же, возможности DUNIT гораздо шире, чем это будет показано в данном материале (перед самым окончанием статьи была найдена интересная ссылка — по ней можно ознакомиться с более изощренным применением DUNIT).

Попытаемся разобраться с проблемой масштабирования форм. Проведя то, что обычно называется предварительным расследованием; покопавшись в интернет, заглянув в хелп, почитав книги, спросив товарищей (нужное подчеркнуть); выяснилось что, можно принудить форму автоматически масштабировать собственные размеры, а так же размеры и положение размещенных на ней визуальных компонентов, при изменении размера экранного шрифта. Для этого необходимо проверить и если нужно установить свойства формы, в нашем случае FMain, ParentFont = False, Scaled = True, AutoScroll = False и PixelsPerInch равный PixelsPerInch текущего экрана. Данное утверждение верно для форм созданных с помощью Delphi 6.2, для более ранних версий не проверялось. Но, судя по количеству воплей на различных форумах — у некоторых такая проблема была. Впрочем, помнится, еще у М. Канту в «Delphi 2 for Windows95/NT» существовала небольшая глава, освещающая именно такой подход. После рассмотрения исходных кодов VCL Delphi выяснилось, что существует другая проблем

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

Что делает программа, когда создает форму? Если у формы установлены свойства как было указано выше, то в зависимости от того, отличается PixelsPerInch (сокращенно PPI) формы от PPI экрана или нет, происходит умножение значений местоположения компонентов на «новый» PPI и деление на «старый» PPI (в действительности, конечно, всё сложнее, но на первых порах и такого понимания достаточно). Будем называть эту функцию ScaleValue.

Откроем проект testMiniProg, и откроем в нем файлы testAppl.pas и Appl.pas из поддиректории SOURCE. Теперь самое странное: в testAppl.pas создаем процедуру проверки TestScaleValue, и объявляем её в published свойствах TTestUnitAppl:

unit testAppl;

interface

uses

TestFramework, SysUtils, Controls, Forms, Appl;

type

TTestUnitAppl = class(TTestCase)

published

procedure TestScaleValue;

end;

implementation

procedure TTestUnitAppl.TestScaleValue;

var

Test: integer;

begin

Test := ScaleValue(120,96,120);

Check( Test = 96, Format(‘return wrong %d’,[Test]));

end;

initialization

TestFramework.RegisterTest(TTestUnitAppl.Suite);

end.

Главное действие в этом unit, происходит в теле процедуры TestScaleValue, по вызову функции Check, в которой проходит проверки первого параметра, и если он False, то тест считается неудачным. Второй параметр функции Check — сообщение, в котором можно написать, в краткой форме, всё, что вы думаете об отрицательном результате тестирования :). Почему, при заданных значениях входных параметров, в результате должно получиться именно 96? — можно понять в результате несложных математических преобразований исходной формулы. Менее успешные математики могут проверить на калькуляторе :). Что же, мы создали тестирующую процедуру, которая проверит корректность работы нашей функции, при чем сделает это автоматически, стоит лишь запустить тесты. Следует сказать, что проверяться функция будет при каждом запуске тестовой программы, т.е. если вы впоследствии поменяете текст функции, и сделаете это некорректно, то программа тут же сообщит вам об этом. Еще одним положительным свойством такого тестирования, является то, что в сам

у программу не вносится ни каких посторонних тестирующих и проверяющих функций. Далее, в файле Appl.pas, создаем саму функцию:

function ScaleValue(Value, NewPPI, OldPPI: integer): integer;

begin

Result := MulDiv(Value, NewPPI, OldPPI);

end;

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

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

Очевидно, что нам нужны функции, которые бы возвращали значения PPI как времени создания, так и времени исполнения программы, назовем их RtmPPI и DsgnPPI. Напишем тест. Подумав, решаем, что RtmPPI и DsgnPPI должны быть равны по значениям, если разработка программы и тестирование происходит при одних и тех же режима экрана:

procedure TTestUnitAppl.TestDsgnVsRtmPPI;

begin

Check( DsgnPPI = RtmPPI, Format(‘Design time PixelsPerInch not %d DPI’,

[RtmPPI]));

end;

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

function RtmPPI: integer;

begin

Result := Screen.PixelsPerInch;

end;

function DsgnPPI: integer;

begin

Result := 120;

end;

function IsChangePPI: boolean;

begin

Result := DsgnPPI RtmPPI;

end;

К сожалению, функция DsgnPPI возвращает результат, просто используя константу, которая выставляется в зависимости от конкретного PPI, используемого при дизайне (у меня это 120, у вас может быть и другое значение). Несмотря на то, что в хелп указано TForm.PixelsPerInch как свойство, хранящее значение времени создания, проверка показала, что это не так. Рассмотрение исходных текстов подтвердило факт изменения значения TForm.PixelsPerInch при масштабирование формы, во время исполнения. Так как простого и надежного решения данной проблемы у меня ПОКА нет, то поступим в соответствии с принципами Экстремального Программирования — «Если есть что-то что можно отложить на завтра — отложите это». Прошу прощение, у адептов XP, за столь вольную трактовку принципа.

Пришло время заняться процедурой, которая будет масштабировать Constraints компонентов. Собственно говоря, это свойство наследуется от TControl, по этому, будем обращаться именно к нему. Подумаем, как тестировать изменение Constraints. Первое, что приходит в голову, это создать специальную тестовую форму. Конечно, такой путь несколько сложноват, однако эта форма, скорее всего, пригодиться и в дальнейшем. Выбираем меню File | New | Form, даем название testForm и сохраняем как testUnit в поддиректории TEST, если Delphi предложит сохранить еще и проект, смело откажитесь. Не забудьте установить свойства формы так, как было описано ранее. Добавьте, в uses Appl. Проверьте, в меню Project | Options, новая форма должна располагаться в Available Forms, то есть не должна создаваться автоматически, при запуске приложения. Создайте в Events формы событие OnClose:

procedure TtestForm.FormClose(Sender: TObject; var Action: TCloseAction);

begin

Action := caFree;

end;

Это заставит удалиться форму из памяти самостоятельно, после закрытия. Не забудьте, выполнить, для testAppl.pas, дополнение через File | Use Unit: Вот, теперь создадим TestChangeConstraints. Что бы легче было тестировать, и избежать неоднозначности, воспользуемся опытом тестирования ScaleValue и зададим размеры формы кратные 120, например 480, после масштабирования должно получиться 384. Так как, отдельные числа используются в unit более чем один раз, то вынесем их в константы.

const

testOldPPI = 120;

testNewPPI = 96;

procedure TTestUnitAppl.TestChangeConstraints;

var

OK1, OK2: boolean;

Size1, Size2: integer;

begin

OK1 := False;

OK2 := False;

Size1 := testOldPPI * 4;

Size2 := ScaleValue(Size1, testNewPPI, testOldPPI);

testForm := TtestForm.Create(Application);

try

testForm.Constraints.MaxHeight := Size1;

testForm.Constraints.MinHeight := Size1;

testForm.Constraints.MaxWidth := 0;

testForm.Constraints.MinWidth := Size1;

ChangeConstraints(testForm as TControl, testNewPPI, testOldPPI);

OK1 := (testForm.Constraints.MaxHeight = Size2) and

(testForm.Constraints.MinHeight = Size2) and

(testForm.Constraints.MaxWidth = 0) and

(testForm.Constraints.MinWidth = Size2);

ChangeConstraints(testForm as TControl, testOldPPI, testNewPPI);

OK2 := (testForm.Constraints.MaxHeight = Size1) and

(testForm.Constraints.MinHeight = Size1) and

(testForm.Constraints.MaxWidth = 0) and

(testForm.Constraints.MinWidth = Size1);

finally

testForm.Close;

Check(OK1 and OK2, ‘failed test’);

end;

end;

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

procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer);

begin

with Control.Constraints do

begin

if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);

if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);

if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);

if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);

end;

end;

Запускаем тест — «Шеф!!! Всё пропало!!!» — в чем же дело? А дело в том, что Constraints для минимальных и максимальных значений взаимозависимы. Максимальное значение не может быть меньше минимального и наоборот, и если происходит присвоение некорректного, с этой точки зрения значения, то оно изменяется в нужную сторону. Такое поведение весьма логично, но нас оно не всегда устраивает, по тому что, нам бы хотелось, что бы такое выравнивание сработало после наших изменений. Кстати, вот вам и первый пойманный баг, и довольно хитрый :). Поспешный поиск дихлофоса от Borland. , среди методов TControl, напоминавших по духу, что-то вроде DisabledAlign ничего не дал. Пришлось воспользоваться простым дедовским антитараканным средством — типа «тапочек»:

procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer);

begin

with Control.Constraints do

begin

if NewPPI > OldPPI then

begin

if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);

if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);

if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);

if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);

end

else

begin

if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);

if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);

if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);

if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);

end;

end;

end;

Тест, зеленый цвет, «едем» дальше… Дальше? А дальше, расположим на testForm какие-нибудь визуальные компоненты, …даааа побольше :). В принципе, TestChangeConstraints показал, что процедура работает успешно, с наследником TForm, но не мешало бы, проверить её и с другими компонентами, хотя бы некоторую их часть (нет у нас такого требования — тестировать VCL). Так как предполагаемый процесс тестирования вполне однообразен, то создадим функцию, которой будем передавать компонент, из числа тех, которые расположены на форме, а возвращать она будет — «да» или «нет».

function TTestUnitAppl.TestScaleControl(Control: TControl): boolean;

var

OK1, OK2: boolean;

Size1, Size2: integer;

begin

OK1 := False;

OK2 := False;

Size1 := testOldPPI;

Size2 := ScaleValue(Size1, testNewPPI, testOldPPI);

testForm := TtestForm.Create(Application);

try

Control.Constraints.MaxHeight := Size1;

Control.Constraints.MinHeight := 0;

Control.Constraints.MaxWidth := Size1;

Control.Constraints.MinWidth := Size1;

ChangeConstraints(Control, testNewPPI, testOldPPI);

OK1 := (Control.Constraints.MaxHeight = Size2) and

(Control.Constraints.MinHeight = 0) and

(Control.Constraints.MaxWidth = Size2) and

(Control.Constraints.MinWidth = Size2);

ChangeConstraints(Control, testOldPPI, testNewPPI);

OK2 := (Control.Constraints.MaxHeight = Size1) and

(Control.Constraints.MinHeight = 0) and

(Control.Constraints.MaxWidth = Size1) and

(Control.Constraints.MinWidth = Size1);

finally

testForm.Close;

Result := OK1 and OK2;

end;

end;

Тестовая функция, например, для Label1, будет выглядеть так:

procedure TTestUnitAppl.TestScaleLabel;

begin

Check(TestScaleControl(testForm.Label1 as TControl), ‘failed test ‘);

end;

Если все тесты проходят успешно, то с определенной долей вероятности можно утверждать, что мы теперь знаем, как настроить форму так, что бы она автоматически масштабировались, по крайней мере в пределах, которые обеспечивает Delphi. Так же сможем масштабировать Constraints отдельно взятого контрола окна, при необходимости. Думаю, сфера использования ChangeConstraints довольно ограниченна, но в большинстве случаев результаты, полученные с помощью таких простых средств — вполне удовлетворительные. Можно было бы разработать функцию, которая бы сама изменяла Constraints у всех элементов формы. Желающие могут попробовать свои силы самостоятельно, не забудьте только прислать пример с тестом, и он будет включен в проект. По моему скромному мнению, решить эту проблему кардинально и качественно, можно лишь на уровне изменения исходного кода VCL. Хотя, «неумение» Constraints корректировать свои значения во время масштабирование окна и не является «официальным» багом но, очень хочется надеяться, что авторы Delphi 7 поза

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

И так, мы провели некоторые технологические тесты, и убедились в работоспособности функций и процедур основной программы. Пришло время заняться функциональными тестами, то есть тестами, в которых проводится общая проверка на соответствие наших решений требованиям. Наиболее наблюдательные читатели должны были заметить, что к самой программе мы еще и не прикасались, но уже имеем для неё несколько работоспособных функций :). Проводить функциональное тестирование можно по-разному, и в принципе, лучше всего на рабочем приложении. У нас, его пока нет, кроме того, оценить правильность масштабирования можно на любом примере, ведь от нас не требуется реакция (нажатие кнопки, движение мыши и т.д.). Нам нужно просто посмотреть. Так что, воспользуемся testForm и разместим на ней 3 компонента TLabel. В свойство Caption каждой занесем такой текст «0123456789». У Label2 установим Constraints равными Width, у Label3 минимальное и максимальное значения отличающееся не менее чем на 50%, у Label4 минимальное и максимальное знач

ения отличающееся на 5%.

procedure TTestUnitAppl.TestFuncScale;

begin

if IsChangePPI then

begin

testForm := TtestForm.Create(Application);

try

testForm.ShowModal;

finally

testForm.Close;

end;

end;

Check(True, ‘very strange ‘);

end;

Тест очень прост, создается и визуализируется окно, рассматривается и закрывается. Процедура выполняется при запуске тестовой программы, если установлено иное значение PPI, чем использовалось при создании. И она всегда завершается успешно, что бы не портить общие «показатели» :). Можно откомпилировать тестовую программу, изменить размер шрифта экрана, перезагрузиться, запустить тест. Естественно, наш тест TestDsgnVsRtmPPI не должен пройти. Зато появиться окно testForm, где можно будет видеть результат масштабирования. Скажу прямо, LabeledEdit меня крайне разочаровал, впрочем, я его всегда подозревал и никогда им непользовался. Зато Label’ы вели себя так как им предписано. Закрываем окно, изменяем шрифт экрана, перезагружаемся, запускаем Delphi. Дальнейшие ухищрения в процессе тестирования, уважаемый читатель, может продолжить и самостоятельно.

Продолжение следует …

Declaimer aka Отмазка.

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

Исходную партитуру и ноты можно взять здесь.

Любые претензии и предложения принимаются в обсуждение и/или мылом.

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

С особым вниманием будут рассмотрены уточнения списка требований и новые тесты.

Все копирайты, если они известны, указаны. Иначе, автор не известен или копирайт утерян.

Проект создан в Delphi6 MiniProg.zip (44.3K)

{/codecitation}

DOS команды

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

…Ну! И кто открывал бутылку об F8 ?!

rundll32 shell32.dll,Control_RunDLL

Выводит панель управления

rundll32 shell32.dll,OpenAs_ RunDLL

Выводит окошко «Открыть с помощью…»

rundll32 shell32.dll,ShellAboutA Info-Box

Показать окно «About Windows»

rundll32 shell32.dll,Control_RunDLL desk.cpl

Открыть свойства экрана

rundll32 user,cascadechildwindows

Сортировка окон каскадом

rundll32 user,tilechildwindows

Сортировка окон вниз

rundll32 user,repaintscreen

Обновить рабочий стол

rundll32 shell,shellexecute Explorer

Запустить проводник Windows

rundll32 keyboard,disable

Вырубить клавиатуру

rundll32 mouse,disable

Вырубить мышь

rundll32 user,swapmousebutton

Поменять местами кнопки мыши

rundll32 user,setcursorpos

Сместить курсор крысы в левый верхний угол

rundll32 user,wnetconnectdialog

Вызвать окно «Подключение сетевого диска»

rundll32 user,wnetdisconnectdialog

Вызвать окно «Отключение сетевого диска»

rundll32 user,disableoemlayer

Спровоцировать сбой

rundll32 diskcopy,DiskCopyRunDll

Показать окно «Copy Disk»

rundll32 maui.dll,RnaWizard

Вывод окна «Установка связи», с ключом «/1» — без окна

rundll32 shell32,SHFormatDrive

Вызвать окно «Форматирование диск 3,5(А)»

rundll32 shell32,SHExitWindowsEx-1

Перегрузить explorer

rundll32 shell32,SHExitWindowsEx 1

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

rundll32 shell32,SHExitWindowsEx 0

Завершить работу текущего пользователя

rundll32 shell32,SHExitWindowsEx 2

Windows-98-PC boot

rundll32 krnl386.exe,exitkernel

Выход из Windows без любых вопросов

rundll maui.dll,RnaDial”MyConnect”

Вызвать окно «Установка связи» с соединением «MyConnect»

rundll32 msprint2.dll,RUNDLL_PrintTestPage

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

rundll32 user,setcaretblinktime

Установить новую частоту мигания курсора

rundll32 user,setdoubleclicktime

Установить новую скорость двойного нажатия

rundll32 sysdm.cpl,InstallDevice_Rundll

Установить non-Plug

CreateProcess, который возвращает консольный вывод

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

— Можно ли научить слона работать в Windows?

— Нет, он ведь боится мышей.

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;

{/codecitation}

Прочитать ROM-BIOS

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

// An Example of this unit is availabe as Demo Download.

// Ein Beispiel zur Anwendung dieser Unit kann als Demo heruntergeladen werden.

////////////////////////////////////////////////////////////////////////////////

//

// BIOS Helper for Delphi

//

// BIOS related utilities for Win9x and WinNT(i386)

//

////////////////////////////////////////////////////////////////////////////////

//

// The Original Code is:

// BiosHelp.pas, released 2001-09-02.

//

// The Initial Developer of the Original Code is Nico Bendlin.

//

// Portions created by Nico Bendlin are

// Copyright (C) 2001-2003 Nico Bendlin. All Rights Reserved.

//

// Contributor(s):

// Nico Bendlin

//

// The contents of this file are subject to the Mozilla Public License Version

// 1.1 (the «License»); you may not use this file except in compliance with the

// License. You may obtain a copy of the License at http://www.mozilla.org/MPL/

//

// Software distributed under the License is distributed on an «AS IS» basis,

// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for

// the specific language governing rights and limitations under the License.

//

// Alternatively, the contents of this file may be used under the terms of

// either the GNU General Public License Version 2 or later (the «GPL»), or

// the GNU Lesser General Public License Version 2.1 or later (the «LGPL»),

// in which case the provisions of the GPL or the LGPL are applicable instead

// of those above. If you wish to allow use of your version of this file only

// under the terms of either the GPL or the LGPL, and not to allow others to

// use your version of this file under the terms of the MPL, indicate your

// decision by deleting the provisions above and replace them with the notice

// and other provisions required by the GPL or the LGPL. If you do not delete

// the provisions above, a recipient may use your version of this file under

// the terms of any one of the MPL, the GPL or the LGPL.

//

////////////////////////////////////////////////////////////////////////////////

//

// Revision:

//

// 2003-02-15 2.00 [NicoDE]

// — generic dump method completely rewritten

// — default range is now E000:0000-F000:FFFF

//

////////////////////////////////////////////////////////////////////////////////

{$IFDEF CONDITIONALEXPRESSIONS}

{$DEFINE DELPHI6UP}

{$IF NOT DEFINED(VER140)}

{$DEFINE DELPHI7UP}

{$IFEND}

{$ENDIF}

unit BiosHelp {$IFDEF DELPHI6UP} platform {$ENDIF};

{$MINENUMSIZE 4}

{$WEAKPACKAGEUNIT}

{$IFDEF DELPHI7UP}

{$WARN UNSAFE_TYPE OFF}

{$WARN UNSAFE_CODE OFF}

{$ENDIF}

interface

uses

Windows;

const

RomBiosDumpBase = $000E0000;

RomBiosDumpEnd = $000FFFFF;

RomBiosDumpSize = RomBiosDumpEnd — RomBiosDumpBase 1;

type

PRomBiosDump = ^TRomBiosDump;

TRomBiosDump = array [RomBiosDumpBase..RomBiosDumpEnd] of Byte;

type

TRomDumpMethod = (rdmAutomatic, // Autodetect OS type and use proper method

rdmGeneric, // Use 16-bit EXE program to dump the BIOS

rdmMemory, // Dump from process’s address space (Win9x)

rdmPhysical // Dump from physical memory object (WinNT)

);

function DumpRomBios(out Dump: TRomBiosDump;

Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;

function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;

Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;

procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;

var Buffer; Size: Cardinal);

procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;

var Buffer; Size: Cardinal);

function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;

function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;

implementation

////////////////////////////////////////////////////////////////////////////////

//

// DumpRomBios16 (rdmGeneric)

//

// Creates an 16-bit EXE program in TEMP and runs it redirected to an file.

//

// WARNING: One day 16-bit code will not run on future Windows.

// WARNING: You are dumping the BIOS inside the MS-DOS ’emulator’.

//

function _RomDumpCode(RomBase: Pointer; RomSize: Cardinal;

out Code: Pointer; out Size: Cardinal): Boolean;

const

BlockSize = $1000;

type // ; RomDump (dumps mem to STDOUT)

PRomDumpCode = ^TRomDumpCode; // ; BlockSize MUST be multiple of 10h.

TRomDumpCode = packed record //

_header: TImageDosHeader; //

_notice: array[0..$4F] of AnsiChar; // @@note: db ‘RomDump 2.0’, …

init: packed record // @@init:

_mov_44: array[0..2] of Byte; // mov ax, 4400h

_mov_bx: array[0..2] of Byte; // mov bx, 0001h

_dos_21: array[0..1] of Byte; // int 21h

_jcf_18: array[0..1] of Byte; // jc @@code

_and_dx: array[0..3] of Byte; // and dx, 0082h

_cmp_dx: array[0..3] of Byte; // cmp dx, 0082h

_jne_0E: array[0..1] of Byte; // jne @@code

_psh_cs: Byte; // push cs

_pop_ds: Byte; // push ds

_mov_dx: array[0..2] of Byte; // mov dx, offset @@note

_mov_09: array[0..1] of Byte; // mov ah, 09h

_int_21: array[0..1] of Byte; // int 21h

_mov_4C: array[0..2] of Byte; // mov ax, 4C01h

_int_20: array[0..1] of Byte; // int 21h

end; //

code: packed record // @@code:

_mov_cx: Byte;

BlockCount: Word; // mov cx,

_mov_dx: Byte;

DatSegment: Word; // mov dx,

_jcx_1C: array[0..1] of Byte; // jcxz @@rest

end; //

loop: packed record // @@loop:

_psh_cx: Byte; // push cx

_psh_dx: Byte; // push dx

_mov_ds: array[0..1] of Byte; // mov ds, dx

_mov_dx: Byte;

DatOffset: Word; // mov dx,

_mov_cx: array[0..2] of Byte; // mov cx,

_mov_bx: array[0..2] of Byte; // mov bx, 0001h

_mov_ax: array[0..2] of Byte; // mov ax, 4000h

_int_21: array[0..1] of Byte; // int 21h

_pop_dx: Byte; // pop dx

_pop_cx: Byte; // pop cx

_jcf_1C: array[0..1] of Byte; // jc @@exit

_add_dx: array[0..3] of Byte; // add dx,

_lop_E4: array[0..1] of Byte; // loop @@loop

end; //

rest: packed record // @@rest:

_mov_ds: array[0..1] of Byte; // mov ds, dx

_mov_dx: Byte;

DatOffset: Word; // mov dx,

_mov_cx: Byte;

LenghtMod: Word; // mov cx,

_mov_bx: array[0..2] of Byte; // mov bx, 0001h

_mov_ax: array[0..2] of Byte; // mov ax, 4000h

_jcx_06: array[0..1] of Byte; // jcxz @@exit

_int_21: array[0..1] of Byte; // int 21h

_jcf_02: array[0..1] of Byte; // jc @@exit

_mov_al: array[0..1] of Byte; // mov al, 00h

end; //

Exit: packed record // @@exit:

_mov_ah: array[0..1] of Byte; // mov ah, 4Ch

_int_21: array[0..1] of Byte; // int 21h

end; //

end;

const

RomDumpCodeSize = SizeOf(TRomDumpCode) — SizeOf(TImageDosHeader);

RomDumpCode: TRomDumpCode = (_header: (e_magic: IMAGE_DOS_SIGNATURE;

e_cblp: Word(RomDumpCodeSize) and $1FF;

e_cp: Word((RomDumpCodeSize — 1) shr 9) 1;

e_crlc: $0000;

e_cparhdr: SizeOf(TImageDosHeader) shr 4;

e_minalloc: $0000;

e_maxalloc: $FFFF;

e_ss: $0000;

e_sp: $1000;

e_csum: $0000;

e_ip: SizeOf(RomDumpCode._notice);

e_cs: $0000;

e_lfarlc: SizeOf(TImageDosHeader);

e_ovno: $0000;

e_res: ($0000, $0000, $0000, $0000);

e_oemid: $0000;

e_oeminfo: $0000;

e_res2: ($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,

$0000, $0000);

_lfanew: $00000000

);

_notice: #13#10

‘RomDump 2.0’#13#10

‘Copyright (c) 2003 Nico Bendlin’#13#10

#13#10

‘Usage: RomDump > filename’#13#10

#13#10$’;

init: (_mov_44: ($B8, $00, $44);

_mov_bx: ($BB, $01, $00);

_dos_21: ($CD, $21);

_jcf_18: ($72, $18);

_and_dx: ($81, $E2, $82, $00);

_cmp_dx: ($81, $FA, $82, $00);

_jne_0E: ($75, $0E);

_psh_cs: $0E;

_pop_ds: $1F;

_mov_dx: ($BA, $00, $00);

_mov_09: ($B4, $09);

_int_21: ($CD, $21);

_mov_4C: ($B8, $01, $4C);

_int_20: ($CD, $21);

);

code: (_mov_cx: $B9; BlockCount: $0010;

_mov_dx: $BA; DatSegment: $F000;

_jcx_1C: ($E3, $1C)

);

loop: (_psh_cx: $51;

_psh_dx: $52;

_mov_ds: ($8E, $DA);

_mov_dx: $BA; DatOffset: $0000;

_mov_cx: ($B9, Lo(BlockSize), Hi(BlockSize));

_mov_bx: ($BB, $01, $00);

_mov_ax: ($B8, $00, $40);

_int_21: ($CD, $21);

_pop_dx: $5A;

_pop_cx: $59;

_jcf_1C: ($72, $1C);

_add_dx: ($81, $C2, Lo(BlockSize shr 4), Hi(BlockSize shr 4));

_lop_E4: ($E2, $E4)

);

rest: (_mov_ds: ($8E, $DA);

_mov_dx: $BA; DatOffset: $0000;

_mov_cx: $B9; LenghtMod: $0000;

_mov_bx: ($BB, $01, $00);

_mov_ax: ($B8, $00, $40);

_jcx_06: ($E3, $06);

_int_21: ($CD, $21);

_jcf_02: ($72, $02);

_mov_al: ($B0, $00)

);

Exit: (_mov_ah: ($B4, $4C);

_int_21: ($CD, $21)

)

);

begin

Result := False;

if (RomSize > 0) and (RomSize <= $100000) and

(Cardinal(RomBase) < $100000) and

(Cardinal(RomBase) RomSize <= $100000) then

begin

Size := SizeOf(TRomDumpCode);

Code := Pointer(LocalAlloc(LPTR, Size));

if Code nil then

try

PRomDumpCode(Code)^ := RomDumpCode;

with PRomDumpCode(Code)^ do

begin

code.BlockCount := Word(RomSize div BlockSize);

code.DatSegment := Word(Cardinal(RomBase) shr 4);

loop.DatOffset := Word(Cardinal(RomBase)) and $000F;

rest.DatOffset := loop.DatOffset;

rest.LenghtMod := Word(RomSize mod BlockSize);

end;

Result := True;

except

LocalFree(HLOCAL(Code));

Code := nil;

Size := 0;

end;

end;

end;

function _SaveRomDumpCodeToFile(RomBase: Pointer; RomSize: Cardinal;

const FileName: string): Boolean;

var

Code: Pointer;

Size: Cardinal;

Hand: THandle;

Num: DWORD;

begin

Result := False;

if _RomDumpCode(RomBase, RomSize, Code, Size) then

try

Hand := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,

CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

if Hand INVALID_HANDLE_VALUE then

try

Result := WriteFile(Hand, Code^, Size, Num, nil) and (Num = Size);

if not Result then

DeleteFile(PChar(FileName));

finally

CloseHandle(Hand);

end;

finally

LocalFree(HLOCAL(Code));

end;

end;

function _ExecuteRomDumpCode(const Code, Dump: string; Timeout: DWORD): Boolean;

var

ComSpec: string;

StartInfo: TStartupInfo;

ProcInfo: TProcessInformation;

ErrorMode: Cardinal;

begin

Result := False;

SetLength(ComSpec, MAX_PATH 1);

SetLength(ComSpec,

GetEnvironmentVariable(‘ComSpec’, PChar(@ComSpec[1]), MAX_PATH));

if Length(ComSpec) <= 0 then

Exit;

FillChar(StartInfo, SizeOf(TStartupInfo), 0);

StartInfo.cb := SizeOf(TStartupInfo);

StartInfo.dwFlags := STARTF_USESHOWWINDOW;

StartInfo.wShowWindow := SW_HIDE;

ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX or

SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOOPENFILEERRORBOX);

try

if CreateProcess(nil, PChar(ComSpec ‘ /C ‘ Code ‘ > ‘ Dump),

nil, nil, False, HIGH_PRIORITY_CLASS, nil, nil, StartInfo, ProcInfo) then

try

Result :=

(WaitForSingleObject(ProcInfo.hProcess, Timeout) WAIT_TIMEOUT);

if not Result then

TerminateProcess(ProcInfo.hProcess, STATUS_TIMEOUT);

finally

CloseHandle(ProcInfo.hThread);

CloseHandle(ProcInfo.hProcess);

end;

finally

SetErrorMode(ErrorMode);

end;

end;

function DumpRomBios16(RomBase: Pointer; RomSize: Cardinal; var Dump;

Timeout: DWORD): Boolean;

var

Tmp: array [0..MAX_PATH] of Char;

Dmp: array [0..MAX_PATH] of Char;

Exe: array [0..MAX_PATH] of Char;

Hnd: THandle;

Num: DWORD;

begin

Result := False;

if GetTempPath(MAX_PATH, Tmp) > 0 then

GetShortPathName(Tmp, Tmp, MAX_PATH)

else

lstrcpy(Tmp, ‘.’);

if GetTempFileName(Tmp, ‘rom’, 0, Dmp) > 0 then

try

lstrcpy(Exe, Dmp);

lstrcat(Exe, ‘.exe’); // Win9x requires .EXE extention

if _SaveRomDumpCodeToFile(RomBase, RomSize, Exe) then

try

if _ExecuteRomDumpCode(Exe, Dmp, Timeout) then

begin

Hnd := CreateFile(Dmp, GENERIC_READ, FILE_SHARE_READ or

FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

if Hnd INVALID_HANDLE_VALUE then

try

Result := ReadFile(Hnd, Dump, RomSize, Num, nil) and (Num = RomSize);

finally

CloseHandle(Hnd);

end;

end;

finally

DeleteFile(Exe);

end;

finally

DeleteFile(Dmp);

end;

end;

////////////////////////////////////////////////////////////////////////////////

//

// DumpRomBios9x (rdmMemory)

//

// Win9x maps the BIOS into every process — therefore it’s directly accessed.

//

function DumpRomBios9x(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;

begin

Result := False;

try

Move(RomBase^, Dump, RomSize);

Result := True;

except

// ignore exeptions

end

end;

////////////////////////////////////////////////////////////////////////////////

//

// DumpRomBiosNt (rdmPhysical)

//

// On WinNT the BIOS is accessable through section ‘\Device\PhysicalMemory’.

// This object can only be opened by members of local ‘Adminstrators’ group.

// ZwOpenSection and RtlNtStatusToDosError are documented in newer MSDN/DDK.

//

type

NTSTATUS = Integer;

PUnicodeString = ^TUnicodeString;

TUnicodeString = packed record

Length: Word;

MaximumLength: Word;

Buffer: PWideChar;

end;

PObjectAttributes = ^TObjectAttributes;

TObjectAttributes = record

Length: ULONG;

RootDirectory: THandle;

ObjectName: PUnicodeString;

Attributes: ULONG;

SecurityDescriptor: PSecurityDescriptor;

SecurityQualityOfService: PSecurityQualityOfService;

end;

TFNZwOpenSection = function(out Section: THandle; Access: ACCESS_MASK;

Attributes: PObjectAttributes): NTSTATUS;

stdcall;

TFNRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD;

stdcall;

const

PhysMemDevName = ‘\Device\PhysicalMemory’;

PhysMemName: TUnicodeString = (Length: Length(PhysMemDevName) * SizeOf(WideChar);

MaximumLength: Length(PhysMemDevName) * SizeOf(WideChar) SizeOf(WideChar);

Buffer: PhysMemDevName;

);

PhysMemMask: ACCESS_MASK = SECTION_MAP_READ;

PhysMemAttr: TObjectAttributes = (Length: SizeOf(TObjectAttributes);

RootDirectory: 0;

ObjectName: @PhysMemName;

Attributes: $00000040; // OBJ_CASE_INSENSITIVE

SecurityDescriptor: nil;

SecurityQualityOfService: nil;

);

var

ZwOpenSection: TFNZwOpenSection;

RtlNtStatusToDosError: TFNRtlNtStatusToDosError;

function DumpRomBiosNt(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;

var

HMod: HMODULE;

Stat: NTSTATUS;

Sect: THandle;

View: Pointer;

begin

Result := False;

HMod := GetModuleHandle(‘ntdll.dll’);

if HMod = 0 then

SetLastError(ERROR_CALL_NOT_IMPLEMENTED)

else

begin

if not Assigned(ZwOpenSection) then

ZwOpenSection := GetProcAddress(HMod, ‘ZwOpenSection’);

if not Assigned(RtlNtStatusToDosError) then

RtlNtStatusToDosError := GetProcAddress(HMod, ‘RtlNtStatusToDosError’);

if not Assigned(ZwOpenSection) or not Assigned(RtlNtStatusToDosError) then

SetLastError(ERROR_CALL_NOT_IMPLEMENTED)

else

begin

Stat := ZwOpenSection(Sect, PhysMemMask, @PhysMemAttr);

if Stat >= 0 then

try

View := MapViewOfFile(Sect, PhysMemMask, 0, Cardinal(RomBase), RomSize);

if View nil then

try

Move(View^, Dump, RomSize);

Result := True;

finally

UnmapViewOfFile(View);

end;

finally

CloseHandle(Sect);

end

else

SetLastError(RtlNtStatusToDosError(Stat));

end;

end;

end;

////////////////////////////////////////////////////////////////////////////////

//

// DumpRomBios(Ex)

//

// Public functions to call OS-dependent implementations.

//

function DumpRomBios(out Dump: TRomBiosDump;

Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;

begin

Result := DumpRomBiosEx(Pointer(RomBiosDumpBase), RomBiosDumpSize, Dump,

Method, Timeout);

end;

function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;

Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;

begin

Result := False;

case Method of

rdmAutomatic:

if (GetVersion() and $80000000) 0 then

Result := DumpRomBios9x(RomBase, RomSize, Dump)

else

begin

Result := DumpRomBiosNt(RomBase, RomSize, Dump);

if not Result then

DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));

end;

rdmGeneric:

Result := DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));

rdmMemory:

Result := DumpRomBios9x(RomBase, RomSize, Dump);

rdmPhysical:

Result := DumpRomBiosNt(RomBase, RomSize, Dump);

else

SetLastError(ERROR_INVALID_PARAMETER);

end;

end;

////////////////////////////////////////////////////////////////////////////////

//

// ReadRomDumpBuffer(Ex) / GetRomDumpAddr(Ex)

//

// Utilities to simplify the access to dumps.

//

procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;

var Buffer; Size: Cardinal);

begin

Move(Dump[Cardinal(Addr)], Buffer, Size);

end;

procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;

var Buffer; Size: Cardinal);

begin

Move(Pointer(Cardinal(@Dump) Cardinal(Addr) — Cardinal(Base))^,

Buffer, Size);

end;

function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;

begin

Result := @Dump[Cardinal(Addr)];

end;

function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;

begin

Result := Pointer(Cardinal(@Dump) Cardinal(Addr) — Cardinal(Base));

end;

end.

{/codecitation}

Получить дату BIOS 2

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

function GetBIOSDate: string;

{получение даты BIOS в Win95}

var

s: array[0..7] of char;

p: pchar;

begin

p := @s;

asm

push esi

push edi

push ecx

mov esi,$0ffff5

mov edi,p

mov cx,8

@@1:mov al,[esi]

mov [edi],al

inc edi

inc esi

loop @@1

pop ecx

pop edi

pop esi

end;

setstring(result, s, 8);

end;

{/codecitation}

Получение серийного номера BIOS

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Gua

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Получение серийного номера BIOS

Зависимости:

Автор: Gua, fbsdd@ukr.net, ICQ:141585495, Simferopol

Copyright:

Дата: 03 мая 2002 г.

***************************************************** }

function GetBiosNumber: string;

begin

result := string(pchar(ptr($FEC71)));

end;

{/codecitation}

Как получить информацию о BIOS в Windows NT, 2000, XP

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

В NT/2000/XP не получится прочитать значения прямо из BIOS, однако, ничего не мешает нам считать нужные значения из реестра.

procedure TBIOSInfo.GetRegInfoWinNT;

var

Registryv: TRegistry;

RegPath: string;

sl: TStrings;

begin

Params.Clear;

RegPath := ‘\HARDWARE\DESCRIPTION\System’;

registryv := tregistry.Create;

registryv.rootkey := HKEY_LOCAL_MACHINE;

sl := nil;

try

registryv.Openkey(RegPath, false);

ShowMessage(‘BIOS Date: ‘ RegistryV.ReadString(‘SystemBiosDate’));

sl := ReadMultirowKey(RegistryV, ‘SystemBiosVersion’);

ShowMessage(‘BIOS Version: ‘ sl.Text);

except

end;

Registryv.Free;

if Assigned(sl) then

sl.Free;

end;

На всякий пожарный:

// следующий метод получает многострочные значения из реестра

// и преобразует их в TStringlist

function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;

const

bufsize = 100;

var

i: integer;

s1: string;

sl: TStringList;

bin: array[1..bufsize] of char;

begin

try

result := nil;

sl := nil;

sl := TStringList.Create;

if not Assigned(reg) then

raise Exception.Create(‘TRegistry object not assigned.’);

FillChar(bin, bufsize, #0);

reg.ReadBinaryData(Key, bin, bufsize);

i := 1;

s1 := »;

while i < bufsize do

begin

if ord(bin[i]) >= 32 then

s1 := s1 bin[i]

else

begin

if Length(s1) > 0 then

begin

sl.Add(s1);

s1 := »;

end;

end;

inc(i);

end;

result := sl;

except

sl.Free;

raise;

end;

end;

{/codecitation}

Как получить дату BIOS

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Народная примета: если программист в девять утра уже на работе, значит, он еще на работе.

unit BiosDate;

interface

function GetBiosDate: string;

implementation

function SegOfsToLinear(Segment, Offset: Word): Integer;

begin

result := (Segment shl 4) or Offset;

end;

function GetBiosDate: string;

begin

result := string(PChar(Ptr(SegOfsToLinear($F000, $FFF5))));

end;

end.

{/codecitation}

Как можно из Delphi отслеживать все события Windows?

{codecitation class=»brush: pascal; gutter: false;» width=»500px»}

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
{$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}

unit ShellNotify;
interface

uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
{$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
ShlObj;

type
NOTIFYREGISTER = record
pidlPath : PItemIDList;
bWatchSubtree : boolean;
end;

PNOTIFYREGISTER = ^NOTIFYREGISTER;

const
SNM_SHELLNOTIFICATION = WM_USER +1;
SHCNF_ACCEPT_INTERRUPTS = $0001;
SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
SHCNF_NO_PROXY = $8000;

type
TNotificationEvent = (neAssociationChange, neAttributesChange,
neFileChange, neFileCreate, neFileDelete, neFileRename,
neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,
neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,
neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,
neServerDisconnect, neImageListChange);
TNotificationEvents = set of TNotificationEvent;

TShellNotificationEvent1 = procedure(Sender: TObject;
Path: String)of Object;
TShellNotificationEvent2 = procedure(Sender: TObject;
path1, path2: String) of Object;
// TShellNotificationAttributesEvent = procedure(Sender: TObject;
// OldAttribs, NewAttribs: Integer) of Object;

TShellNotification = class( TComponent )
private
fWatchEvents: TNotificationEvents;
fPath: String;
fActive, fWatch: Boolean;

prevPath1, prevPath2: String;
PrevEvent: Integer;

Handle, NotifyHandle: HWND;

fOnAssociationChange: TNotifyEvent;
fOnAttribChange: TShellNotificationEvent2;
FOnCreate: TShellNotificationEvent1;
FOnDelete: TShellNotificationEvent1;
FOnDriveAdd: TShellNotificationEvent1;
FOnDriveAddGui: TShellNotificationEvent1;
FOnDriveRemove: TShellNotificationEvent1;
FOnMediaInsert: TShellNotificationEvent1;
FOnMediaRemove: TShellNotificationEvent1;
FOnDirCreate: TShellNotificationEvent1;
FOnNetShare: TShellNotificationEvent1;
FOnNetUnShare: TShellNotificationEvent1;
FOnRenameFolder: TShellNotificationEvent2;
FOnItemRename: TShellNotificationEvent2;
FOnFolderRemove: TShellNotificationEvent1;
FOnServerDisconnect: TShellNotificationEvent1;
FOnFolderUpdate: TShellNotificationEvent1;

function PathFromPidl(Pidl: PItemIDList): String;
procedure SetWatchEvents(const Value: TNotificationEvents);
function GetActive: Boolean;
procedure SetActive(const Value: Boolean);
procedure SetPath(const Value: String);
procedure SetWatch(const Value: Boolean);
protected
procedure ShellNotifyRegister;
procedure ShellNotifyUnregister;
procedure WndProc(var Message: TMessage);

procedure DoAssociationChange; dynamic;
procedure DoAttributesChange(Path1, Path2: String); dynamic;
procedure DoCreateFile(Path: String); dynamic;
procedure DoDeleteFile(Path: String); dynamic;
procedure DoDriveAdd(Path:String); dynamic;
procedure DoDriveAddGui(Path: String); dynamic;
procedure DoDriveRemove(Path: String); dynamic;
procedure DoMediaInsert(Path: String); dynamic;
procedure DoMediaRemove(Path: String); dynamic;
procedure DoDirCreate(Path: String); dynamic;
procedure DoNetShare(Path: String); dynamic;
procedure DoNetUnShare(Path: String); dynamic;
procedure DoRenameFolder(Path1, Path2: String); dynamic;
procedure DoRenameItem(Path1, Path2: String); dynamic;
procedure DoFolderRemove(Path: String); dynamic;
procedure DoServerDisconnect(Path: String); dynamic;
procedure DoDirUpdate(Path: String); dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Path: String read fPath write SetPath;
property Active: Boolean read GetActive write SetActive;
property WatchSubTree: Boolean read fWatch write SetWatch;

property WatchEvents: TNotificationEvents
read fWatchEvents write SetWatchEvents;

property OnAssociationChange: TNotifyEvent
read fOnAssociationChange write FOnAssociationChange;

property OnAttributesChange: TShellNotificationEvent2
read fOnAttribChange write fOnAttribChange;

property OnFileCreate: TShellNotificationEvent1
read FOnCreate write FOnCreate;

property OnFolderRename: TShellNotificationEvent2
read FOnRenameFolder write FOnRenameFolder;

property OnFolderUpdate: TShellNotificationEvent1
read FOnFolderUpdate write FOnFolderUpdate;

property OnFileDelete: TShellNotificationEvent1
read FOnDelete write FOnDelete;

property OnDriveAdd: TShellNotificationEvent1
read FOnDriveAdd write FOnDriveAdd;

property OnFolderRemove: TShellNotificationEvent1
read FOnFolderRemove write FOnFolderRemove;

property OnItemRename: TShellNotificationEvent2
read FOnItemRename write FOnItemRename;

property OnDriveAddGui: TShellNotificationEvent1
read FOnDriveAddGui write FOnDriveAddGui;

property OnDriveRemove: TShellNotificationEvent1
read FOnDriveRemove write FOnDriveRemove;

property OnMediaInserted: TShellNotificationEvent1
read FOnMediaInsert write FOnMediaInsert;

property OnMediaRemove: TShellNotificationEvent1
read FOnMediaRemove write FOnMediaRemove;

property OnDirCreate: TShellNotificationEvent1
read FOnDirCreate write FOnDirCreate;

property OnNetShare: TShellNotificationEvent1
read FOnNetShare write FOnNetShare;

property OnNetUnShare: TShellNotificationEvent1
read FOnNetUnShare write FOnNetUnShare;

property OnServerDisconnect: TShellNotificationEvent1
read FOnServerDisconnect write FOnServerDisconnect;
end;

function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;
wEventMask : cardinal; uMsg: UINT; cItems : integer;
lpItems : PNOTIFYREGISTER) : HWND; stdcall;
function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;
function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;
var Attributes: ULONG):HResult; stdcall;
implementation

const Shell32DLL = ‘shell32.dll’;

function SHChangeNotifyRegister; external Shell32DLL index 2;
function SHChangeNotifyDeregister; external Shell32DLL index 4;
function SHILCreateFromPath; external Shell32DLL index 28;

{ TShellNotification }

constructor TShellNotification.Create(AOwner: TComponent);
begin
inherited Create( AOwner );
if not (csDesigning in ComponentState) then
Handle := AllocateHWnd(WndProc);
end;

destructor TShellNotification.Destroy;
begin
if not (csDesigning in ComponentState) then
Active := False;
if Handle 0 then DeallocateHWnd( Handle );
inherited Destroy;
end;

procedure TShellNotification.DoAssociationChange;
begin
if Assigned( fOnAssociationChange ) and (neAssociationChange in fWatchEvents) then
fOnAssociationChange( Self );
end;

procedure TShellNotification.DoAttributesChange;
begin
if Assigned( fOnAttribChange ) then
fOnAttribChange( Self, Path1, Path2 );
end;

procedure TShellNotification.DoCreateFile(Path: String);
begin
if Assigned( fOnCreate ) then
FOnCreate(Self, Path)
end;

procedure TShellNotification.DoDeleteFile(Path: String);
begin
if Assigned( FOnDelete ) then
FOnDelete(Self, Path);
end;

procedure TShellNotification.DoDirCreate(Path: String);
begin
if Assigned( FOnDirCreate ) then
FOnDirCreate( Self, Path );
end;

procedure TShellNotification.DoDirUpdate(Path: String);
begin
if Assigned( FOnFolderUpdate ) then
FOnFolderUpdate(Self, Path);
end;

procedure TShellNotification.DoDriveAdd(Path: String);
begin
if Assigned( FOnDriveAdd ) then
FOnDriveAdd(Self, Path);
end;

procedure TShellNotification.DoDriveAddGui(Path: String);
begin
if Assigned( FOnDriveAddGui ) then
FOnDriveAdd(Self, Path);
end;

procedure TShellNotification.DoDriveRemove(Path: String);
begin
if Assigned( FOnDriveRemove ) then
FOnDriveRemove(Self, Path);
end;

procedure TShellNotification.DoFolderRemove(Path: String);
begin
if Assigned(FOnFolderRemove) then
FOnFolderRemove( Self, Path );
end;

procedure TShellNotification.DoMediaInsert(Path: String);
begin
if Assigned( FOnMediaInsert ) then
FOnMediaInsert(Self, Path);
end;

procedure TShellNotification.DoMediaRemove(Path: String);
begin
if Assigned(FOnMediaRemove) then
FOnMediaRemove(Self, Path);
end;

procedure TShellNotification.DoNetShare(Path: String);
begin
if Assigned(FOnNetShare) then
FOnNetShare(Self, Path);
end;

procedure TShellNotification.DoNetUnShare(Path: String);
begin
if Assigned(FOnNetUnShare) then
FOnNetUnShare(Self, Path);
end;

procedure TShellNotification.DoRenameFolder(Path1, Path2: String);
begin
if Assigned( FOnRenameFolder ) then
FOnRenameFolder(Self, Path1, Path2);
end;

procedure TShellNotification.DoRenameItem(Path1, Path2: String);
begin
if Assigned( FOnItemRename ) then
FonItemRename(Self, Path1, Path2);
end;

procedure TShellNotification.DoServerDisconnect(Path: String);
begin
if Assigned( FOnServerDisconnect ) then
FOnServerDisconnect(Self, Path);
end;

function TShellNotification.GetActive: Boolean;
begin
Result := (NotifyHandle 0) and (fActive);
end;

function TShellNotification.PathFromPidl(Pidl: PItemIDList): String;
begin
SetLength(Result, Max_Path);
if not SHGetPathFromIDList(Pidl, PChar(Result)) then Result := »;
if pos(#0, Result) > 0 then
SetLength(Result, pos(#0, Result));
end;

procedure TShellNotification.SetActive(const Value: Boolean);
begin
if (Value fActive) then
begin
fActive := Value;
if fActive then ShellNotifyRegister else ShellNotifyUnregister;
end;
end;

procedure TShellNotification.SetPath(const Value: String);
begin
if fPath Value then
begin
fPath := Value;
ShellNotifyRegister;
end;
end;

procedure TShellNotification.SetWatch(const Value: Boolean);
begin
if fWatch Value then
begin
fWatch := Value;
ShellNotifyRegister;
end;
end;

procedure TShellNotification.SetWatchEvents(
const Value: TNotificationEvents);
begin
if fWatchEvents Value then
begin
fWatchEvents := Value;
ShellNotifyRegister;
end;
end;

procedure TShellNotification.ShellNotifyRegister;
var
NotifyRecord: PNOTIFYREGISTER;
Flags: DWORD;
Pidl: PItemIDList;
Attributes: ULONG;
begin
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState) then
begin
SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);
NotifyRecord^.pidlPath := Pidl;
NotifyRecord^.bWatchSubtree := fWatch;

if NotifyHandle 0 then ShellNotifyUnregister;
Flags := 0;
if neAssociationChange in FWatchEvents then
Flags := Flags or SHCNE_ASSOCCHANGED;
if neAttributesChange in FWatchEvents then
Flags := Flags or SHCNE_ATTRIBUTES;
if neFileChange in FWatchEvents then
Flags := Flags or SHCNE_UPDATEITEM;
if neFileCreate in FWatchEvents then
Flags := Flags or SHCNE_CREATE;
if neFileDelete in FWatchEvents then
Flags := Flags or SHCNE_DELETE;
if neFileRename in FWatchEvents then
Flags := Flags or SHCNE_RENAMEITEM;
if neDriveAdd in FWatchEvents then
Flags := Flags or SHCNE_DRIVEADD;
if neDriveRemove in FWatchEvents then
Flags := Flags or SHCNE_DRIVEREMOVED;
if neShellDriveAdd in FWatchEvents then
Flags := Flags or SHCNE_DRIVEADDGUI;
if neDriveSpaceChange in FWatchEvents then
Flags := Flags or SHCNE_FREESPACE;
if neMediaInsert in FWatchEvents then
Flags := Flags or SHCNE_MEDIAINSERTED;
if neMediaRemove in FWatchEvents then
Flags := Flags or SHCNE_MEDIAREMOVED;
if neFolderCreate in FWatchEvents then
Flags := Flags or SHCNE_MKDIR;
if neFolderDelete in FWatchEvents then
Flags := Flags or SHCNE_RMDIR;
if neFolderRename in FWatchEvents then
Flags := Flags or SHCNE_RENAMEFOLDER;
if neFolderUpdate in FWatchEvents then
Flags := Flags or SHCNE_UPDATEDIR;
if neNetShare in FWatchEvents then
Flags := Flags or SHCNE_NETSHARE;
if neNetUnShare in FWatchEvents then
Flags := Flags or SHCNE_NETUNSHARE;
if neServerDisconnect in FWatchEvents then
Flags := Flags or SHCNE_SERVERDISCONNECT;
if neImageListChange in FWatchEvents then
Flags := Flags or SHCNE_UPDATEIMAGE;
NotifyHandle := SHChangeNotifyRegister(Handle,
SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,
Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);
end;
end;

procedure TShellNotification.ShellNotifyUnregister;
begin
if NotifyHandle 0 then
SHChangeNotifyDeregister(NotifyHandle);
end;

procedure TShellNotification.WndProc(var Message: TMessage);
type
TPIDLLIST = record
pidlist : array[1..2] of PITEMIDLIST;
end;
PIDARRAY = ^TPIDLLIST;
var
Path1 : string;
Path2 : string;
ptr : PIDARRAY;
repeated : boolean;
event : longint;

begin
case Message.Msg of
SNM_SHELLNOTIFICATION:
begin
event := Message.LParam and ($7FFFFFFF);
Ptr := PIDARRAY(Message.WParam);

Path1 := PathFromPidl( Ptr^.pidlist[1] );
Path2 := PathFromPidl( Ptr^.pidList[2] );

repeated := (PrevEvent = event)
and (uppercase(prevpath1) = uppercase(Path1))
and (uppercase(prevpath2) = uppercase(Path2));

if Repeated then exit;

PrevEvent := Message.Msg;
prevPath1 := Path1;
prevPath2 := Path2;

case event of
SHCNE_ASSOCCHANGED : DoAssociationChange;
SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);
SHCNE_CREATE : DoCreateFile(Path1);
SHCNE_DELETE : DoDeleteFile(Path1);
SHCNE_DRIVEADD : DoDriveAdd(Path1);
SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);
SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);
SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);
SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);
SHCNE_MKDIR : DoDirCreate(Path1);
SHCNE_NETSHARE : DoNetShare(Path1);
SHCNE_NETUNSHARE : DoNetUnShare(Path1);
SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);
SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);
SHCNE_RMDIR : DoFolderRemove(Path1);
SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);
SHCNE_UPDATEDIR : DoDirUpdate(Path);
SHCNE_UPDATEIMAGE : ;
SHCNE_UPDATEITEM : ;
end;//Case event of
end;//SNM_SHELLNOTIFICATION
end; //case
end;

end.

{/codecitation}