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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


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

БОЛЬШОЙ FAQ ПО DELPHI



Взлом MacroHTML 1.40 beta или детский лепет

Автор: Fess

- Как хакер взламывает банкомат?
1) Берёт с собой ноутбук и молоток
2) Подходит к банкомату
3) Разбивает банкомат молотком
4) Забирает деньги и уходит
- А зачем ему ноутбук?
- Ну а какой-же хакер без ноутбука!

Target: MacroHTML 1.40 beta

Tools:

  • Немного мозгов
  • RegMon 4.13

Пролог

Вступление:

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

Что за прога:

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

Начало

Вы не ошиблись, увидев в инструментах один RegMon будем ломать только с помощью него, и вы увидите, как это просто.

Взлом

Запусакем RegMon и в диалоге Filter... (Ctrl-F) напротив Process Include(s) вписываем mh* (т.е. имя файла начинается с mh) так же уб- ираем галочки напротив Log Writes и Log Success, чтобы протоколировались только не найденные ключи. Применяем установки. Затем запускаем программу и смотрим какие-нибудь интересные ключи. В начале видна такая строка OpenKey HKCU\SOFTWARE\MHTML\RD, т.е. не найден ключ создадим его. Нажи- маем два раза на эту строку, он вызывает regedit и переходит к этому ключу. Создаем недостающий раздел RD. Очищаем лист в RegMon'e и заново запускаем программу.

В начале видна такая строка QueryValueExA HKCU\SOFTWARE\MHTML\RD\LName Так прога ищет такой параметр, название говорит нам, что это имя, значит скорее всего он текстовый создадим его. Очищаем лист и заново запускаем прогу.

Теперь прога ищет такой параметр HKCU\SOFTWARE\MHTML\RD\FName, что-то явно связанное с именем. Значит текстовый создаем его. Опять очищаем лист и запускаем прогу.

О, еще один параметр HKCU\SOFTWARE\MHTML\RD\Email. Опять текстовый. Пишем любой или свой е-майл. Еще раз все перезапускаем, вроде ничего по- хожего больше не видно. Идем в "О программе" и видим там наши введенные данные. Хе-хе-хе вот и все. Не правда ли просто?

Послесловие

Товарищи программисты. Ну что это такое, худшая защита месяца, ЛЮБОЙ крэкер сломает это даже не задумываясь. Если хотите, чтоб за проги платили баблосы защищайте лучше.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

З.Ы. Возможны ошибки. Взлом игры 3 минуты. Написание статьи 50 минут, видите как старался.

With best wishes Fess




Регистрация mIRC32 v5.41

Автор: Russian

ОТ АВТОРА

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

ВВЕДЕНИЕ

Все знают программу для общения в IRC серверах mIRC32.exe (а кто не знает, по- смотрите на http://www.mirc.co.uk). Программа mIRC32 v5.41 является Shareware, после 30 дней ее надо зарегистриро- вать. В принципе можно работать и на этой версии, однако после указанного срока при запуске начинают появляться навязчивые сообщения с предложением сделать регистрацию. Как я попытался это проделать, читайте далее.

ИССЛЕДОВАНИЕ

Для начала я установил на компьютере SoftICE и настроил его так как описано в статье «С чего начинать?». Для таких же как я начинающих, отмечу, что при установ- ке SoftICE сам определяет видеокарту и пытается использовать ее родной драйвер. Здесь главное не поддаться искушению и поступить так, как указано в совете номер один из вышеуказанной статьи, иначе наловитесь всяких ошибок и забудете про иной другой выход из Windows95, кроме как по кнопке Reset (как говорится, проверено на себе). Еще я пользовался дизассемблером WinDasm и редактором QuickView (все программы можно найти в разделе Инструменты). Запустив mIRC32, я посмотрел в меню Help/Register... При выборе данного пункта выводится окошко с предложением ввести имя и регистрационный код и нажать кноп- ку Register. При вводе имени и кода (любых) появляется окно с надписью о том, что все неправильно и надо пытаться сделать все по новой (далее назову его «окно отка- за»).

Сначала я пытался остановить программу mIRC в месте ввода кода и имени уста- новкой прерывания по функции MessageBoxA() (так как по названию программы сразу видно, что она 32-разрядная, использую функции с А на конце):

bpx MessageBoxA

Не помогает. Пробую:

bpx GetDlgItemTextА

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

bpx hmemcpy

(как учит нас Эдуард Титов в сборнике статей о исследовании программ) и

bpx SendDlgItemMessageA.

Вторая более предпочтительна. Небольшая особенность, с которой я столкнулся: после прерывания по SendDialogItemMessage() при нажатии F12 в SoftICE я не толь- ко выходил из функции SendDLgItemMessageA() но и «пролетал» по коду mIRC, по- путно получая «окно отказа» со звуковым сигналом и оказывался опять в каком-то модуле Windows. То есть уже после момента анализа программой вводимой мною информации.

Тогда после прерывания по SendDLgItemMessageA() я стал нажимать клавишу F10 и следить за именем модуля в окне кода SoftICE. После около 200 нажатий и «путеше- ствия» из модуля Kernel32 в модуль User32 и обратно, я все-таки оказался в модуле mirc32 по адресу 0043D19Bh. Участок программы по этому адресу, выглядит в WinDasm следующим образом:


 * Reference To: USER32.SendDlgItemMessageA, Ord:0000h
 |
 :0043D196 E8FAEA0700 Call 004BBC95
 :0043D19B 68701E4D00 push 004D1E70
 * Possible Reference to Dialog: DialogID_003D, CONTROL_ID:02BC, «?»
 |
 :0043D1A0 68BC020000 push 000002BC
 :0043D1A5 6A0D push 0000000D
 * Possible Ref to Menu: MenuID_0013, Item: «Contents»
 |
 * Possible Reference to Dialog: DialogID_0033, CONTROL_ID:0082, «»
 |
 :0043D1A7 6882000000 push 00000082
 :0043D1AC 8B4508 mov eax, dword ptr [ebp+08]
 :0043D1AF 50 push eax
 * Reference To: USER32.SendDlgItemMessageA, Ord:0000h
 |
 :0043D1B0 E8E0EA0700 Call 004BBC95
 :0043D1B5 68701E4D00 push 004D1E70
 :0043D1BA 68B41B4D00 push 004D1BB4
 :0043D1BF E844140500 call 0048E608
 :0043D1C4 85C0 test eax, eax
 :0043D1C6 0F848B000000 je 0043D257
 

Во внутреннем устройстве Windows 95 я, человек, не сильно опытный, но мне по- казалось, что после получения имени и кода (функции со словом Dlg в названии) идет вызов какой-то процедуры по адресу 0043D1BFh. А перед этим в стек заносится два адреса. Поставив прерывание на адрес 043D1BAh можно посмотреть содержимое этих адресов командой db 04d1bb4 и db 04d1E70 (или установив курсор на адрес в окне кода и, нажав правую кнопку мыши, выбрать в появившемся меню пункт Display):


 04D1BB4h Љ введенное Вами имя
 04D1E70h Љ введенный Вами код
 

Значит, вызывается поцедура анализа этих данных. После нее мы видим проверку и переход , если EAX равен нулю. Посмотрев, куда осуществляется переход, Вы уви- дите, что это вывод «окна отказа» и звукового сигнала (функция MessageBeep() сразу после перехода и ссылка на строку):


 * Possible StringData Ref from Data Obj -> «Sorry, your registration... вообщем,
 текст «окна отказа»
 

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

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


 :0048E67E 56 push esi
 :0048E67F E820FEFFFF call 0048E4A4
 :0048E684 85C0 test eax, eax
 :0048E686 7407 je 0048E68F
 :0048E688 B801000000 mov eax, 00000001
 :0048E68D EB02 jmp 0048E691
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0048E686(C)
 |
 :0048E68F 33C0 xor eax, eax
 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:0048E622(U), :0048E634(U), :0048E67C(U), :0048E68D(U)
 |
 :0048E691 5F pop edi
 :0048E692 5E pop esi
 :0048E693 5B pop ebx
 :0048E694 5D pop ebp
 :0048E695 C20800 ret 0008
 

Очевидно, что здесь производится последняя проверка и по ее результатам выс- тавляется содержимое регистра EAX. Так как больше никаких ячеек памяти после финальной проверки не модифицируется, я сделал вывод, что никаких флагов о пра- вильности проверки программа больше не ставит. Она просто проверяет введенные данные на соответсвие своим и без генерации правильного пароля устанваливает EAX в 1 (True), если все нормально и в 0 (False), если есть проблемы. Хоть я так и не увидел своего «правильного» кода, я ввел по адресу 0048E686h пару NOP и тем самым сделал процедуру регистрации автоматической независимо от введенной информации. Но на этом все не закончилось. Дальнейший анализ показал, что зарегистрирован- ная программа пишет в файл mirc.ini строки типа:


 [about]
 show=iamweasel
 

Я попытался подписать такие строки в mirc.ini незарегистрированной программы, но зарегистрированной она от этого отнюдь не стала. Зато обнаружилась следующая интересная деталь: после запуска незарегистрированной версии, версия которая была «зарегистрирована» вышеописанным образом становилась незарегистрированной вновь. Поначалу мне начали мерещиться «секретные флаги» о которых я не узнал, но все оказалось гораздо проще. Зарегистрированная mIRC32 записывает в реестр, в разделе HKEY_Current_User/Software/Mirc некий код (вот для чего процедура кру- тилась) и введенное имя. А незарегистрированная mIRC32 при запуске все это удаля- ет. И потом зарегистрированная mIRC32 не найдя в реестре этих данных становится опять незарегистрированной. Вообщем, сама процедура регистрации, видимо, и со- стоит в этой модификации реестра.

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




Исследование Multi-Edit 8.0. Программа с интересной защитой

Автор: Zet

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

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

Вступление

Недавно мне попался в руки такой редактор - Multi-Edit 7.0. Замечательная вещь, с почти не ограниченной функциональностью, поддержкой любого компилятора - одним словом - лучший редактор для программиста. Потом я поискал и нашел более новую версию - Multi-Edit 8.0. В ней добавлена поддержка Borland Delphi, C++ Builder, Watcom C, а также - прием/передача файлов по FTP. К сожалению, эта версия защищена - при загрузке появляетс сообщение о том, что это демо-версия, в процессе работы появляется то же сообщение, причем каждые 15 минут. Кроме того не работает поддержка FTP и действительно отсутсвует проверка английского правописания.

Инструменты

  • SoftICE 3.23 for Win95
  • Любой шестнадцатиричный редактор файлов

Исследование

Разберемся с тем, что говорилось выше. Для начала я покажу как решить проблему с сообщениями, появляющимися каждые 15 минут. Для этого стоит внимательно изучить функции Win32 API связанные со временем. Исход из того, что программа отсчитывает промежутки в 15 минут, наиболее подходящей функцией является GetTickCount. Эта функция возвращает количество тиков со времени запуска Win95. Исходя из этого, проделаем следующее - запустим SoftICE, за ним наш Multi-Edit. Закроем появившееся красивое окно с сообщением, о том, что это демо-версия. Теперь мы в редакторе. Используя bpx gettickcount я установил контрольную точку. Выйдя из SoftICE практическеи мнгновенно попадаем обратно - в функцию GetTickCount. Нажимаем F12. Теперь мы здесь:


 sub_40F164  proc near
      call  j_GetTickCount
      mov ecx, 37h
      cdq
      idiv  ecx
      retn
 sub_40F164	endp
 

По виду этого куска кода не трудно догадаться, что осуществляется пересчет тиков в более удобные(?) единицы. Нажмем F12 еще раз. Теперь мы здесь:


 sub_411748  proc near   ; CODE XREF: sub_440430+43C
      call    sub_40F164            ; это и есть та самая функци
      mov     ds:dword_449388, eax  ; сохраним текущее значение времени
      mov     eax, ds:dword_449388  ; бесполезная команда
      cmp     eax, ds:dword_44938C  ; сравним
      jz      short loc_41176F      ; равны - ничего не делаем
      mov     eax, ds:off_449A38    ; кол-во тиков равное (некоторое значение+15 минут)
      mov     edx, ds:dword_449388  ; текущее значение
 
      call    sub_40F1AC            ; вредоносная процедура :)
 
 loc_41176F:       ; CODE XREF: sub_411748+15
      mov     eax, ds:dword_449388
      mov     ds:dword_44938C, eax
      retn
 sub_411748  endp
 

Особых пояснений требует только call sub_40F1AC. я не привожу эту процедуру из-за ее громоздкости. Достаточно лишь понять основные ее функции. В общих чертах, эта процедура проверяет, прошло-ли 15 минут со времени появления предидущего демо-окна, и если прошло, показывает то самое окно. Теперь можно подумать, как именно взламывать. Есть несколько вариантов, но что бы не копаться во внутренностях программы, можно использовать простейший - вместо инструкции call sub_40F1AC (кстати - ее длина 5 байт) использовать что-то вроде


 xor eax,eax
 xor eax,eax
 nop
 

Таким образом мы успешно избавились от занудных напоминаний со стороны авторов. Но еще есть над чем поработать! Не очень то хочется каждый раз при запуске программы видеть то самое окно, от которого мы уже успешно избавились. Моя первая мысль была - поставить что-то вроде bpx dialogboxparama, bpx dialogboxindirectparama и запустить эту штуку. Попробуете сами. Никакой реакции. Ну и ладно. Есть еще createdialogparama, createdialogindirectparama и showwindow. Теперь уже есть какой-то результат! Мы снова в SoftICE. А теперь попробуйте найти, что же вызвало к жизни этот код. Если хотите чему-то научиться - не читайте дальше, а попробуйте сами.

Нашли?

Теперь остается только изменить нужное условный/безусловный переход или вызов функции. Остается найти и изменить это место в файле(mew32.dll). Сделаем это и запустим все снова. В лучшем случае - у вас больше никогда не вызовется не одно окно диалога и вообще никакое другое. В худшем - получите GPF of death... А вот теперь и следует сесть и как следует подумать. Подумать очень хорошо. Какая возможность позволяет неограниченно наращивать возможности Multi-Edit? Тот кто его знает, ответят быстро - наличие внутреннего, очень мощного языка макросов. Которые кстати компилируются в некоторое подобие исполняемого кода(в Multi-Edit 8.0 eval copy компилятор отсутствует - для этого то и нужен Multi-Edit 7.0 - там он есть). Уже этого достаточно, чтобы найти решение. Если еще не нашли, то вот вам несколько подсказок - для начала посмотрите файл Src/startup.s в том каталогое где установлен Multi-Edit 7.0. Поле этого посмотрите в обоих программах такой пункт меню - macro/list all macros... Я лично изучал этот список около часа - из простого любопытства. Исходя из полученных сведений можно сделать вывод о том, что ВЕСЬ интерфейс этих программ написан именно на внутреннем языке макросов. Кроме этого есть там и такие замечательные макросы как setserial, setdosserial, serial_test. Теперь выберите Macro/run... и введите setserial. Никакого эффекта. Теперь Serial_test. То же самое. А теперь setdosserial. А вот и окошечко для регистрации пользователей, обладающих старыми версиями под Дос. Если у кого есть старый серийный номер - вводите. У кого нет - идем дальше. Я подумал, что пытаться вычислить пароль не имеет смысла. Кто не согласен - пусть попробует. Если получиться - буду очень рад об этом услышать (сами пароли кстати очень простые). Помните, я говорил посмотреть файл Src/startup.s? Если посмотрели, то какие идеи вам приходят в голову? Если у кого этого файла нет (его нет в Multi-Edit 8.0) ,то вот его содержимое:


 //  #define MEWDEMO
 macro STARTUP DUMP {
 //  The following code used only for the demo
   #ifdef MEWDEMO
   rm('mewdemo^calclag');
   rm('mewdemo^nagevent');
   #endif
 }
 

Здесь rm обозначет run macro. Все еще нет идей? Тогда попробуйте поискать строчки mewdemo^calclag и mewdemo^nagevent в файле mac/mew.mcl в директории с MEW8. Если нашли - то попробуйте заменить их на что-то вроде sdfffwgbssbsqepa. Как вы вероятно догадолись, а вычитал в файлах помощи, скомпилированный файл может содержать несколько макросов, и поэтому в теле файла хранятся имена содержащихся макросов. А в том, что теперь будет вызываться макрос, которого якобы не существует нет ничего страшного - об этом никто никого не уведомляет. Более того - это более эффективный взлом, чем тот, что мы использовали для подавления 15-минутных напоминаний. Если избавиться от этих двух макросов с самого начала, то и напоминания не дадут о себе знать.

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

Заключение

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

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




Исследование Njwin

Необходимые инструменты
1. Отладчик SoftICE 3.23 или более поздний
2. Ваш любимый шестнадцатеричный редактор

Введение

Не так давно наткнулся я на программу под названием Njwin, которая опознает и перекодирует япон- ские, корейские и китайские иероглифы в их "первозданный" вид. Найти программу Njwin 1.6 можно по адресу http://www.njstar.com

Исследование

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

Отключение механизма самоуничтожения

Скопируйте файл Njwin.exe в другое место на случай неудачи и запустите программу. Установите в SoftICE точку прерывания bpx GetModuleFileName, нажмите F5 и закройте Njwin. Вы попадаете в SoftICE. Нажмите F11 и вы окажетесь в модуле Njwin.exe:


 44E9 call KERNEL!GETMODULEFILENAME
 44EE push 1A7Fh
 44F1 push 7688h
 44F4 lea ax, [bp+FEEAh]
 44F8 push ss
 44F9 push ax
 44FA call 1A7F:0856
 44FF add sp,08
 4502 mov si, ax
 4504 mov [bp-0C], dx
 4507 or dx, ax
 4509 jnz 450C
 450B jmp 4698
 450E push 02
 

Протрассируйте код, используя F10, и записав все переходы jz и jnz. Теперь, используя любой шест- надщатеричный редактор, измените что-нибудь в файле Njwin.exe. Откройте его, установите точку пре- рывания на ту же функцию (bpx GetModuleFileName), и закройте Njwin. Попав в SoftICE, снова трасси- руйте код, отыскивая различия..Eduard Titov. Исследование Njwin 2 Для начинающих исследователей Очень скоро вы наткнетесь на место:


 461C JNZ 467A расхождение
 MOV WORDD PTR[BP-12],CFC4
 MOV WORD PTR[BP-10],7BBC
 PUSH 112F
 PUSH 768C
 LEA AX,[BP+FEEA]
 PUSH SS
 PUSH AX
 CALL 112F:0856 вот он, самоубийца
 ADD SP,08
 MOV SI,AX
 MOV [BP-0C],DX
 OR DX,AX
 JZ 4698
 

И убедитесь, что неизмененная программа не делает перехода по адресу 461С (jnt 467A), и делает его по команде jz 4698. Измените jnz на jmp 4698, и вы увидите, что программа перестала самоуничтожаться. Теперь можно внести эти изменения в тело оригинальной программы. Кстати, взглянув повнимательнее на первый кусочек кода, вы увидите знакомый переход по адресу 450В. Можно просто изменить jnz 450C по адресу 4509 на jmp 4698, и вы снова отключите защиту. Теперь можно переходить к регистрации программы.

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

У меня программа не выдавала окна для ввода регистрационной информации, но друзья говорили, что даже после ввода правильной регистрационной информации при перезапуске программы она снова видела себя незарегистрированной, т.е. снова появлялось окошко с напоминанием о необходимости ре- гистрации и т.д. Как избавиться от этого окошка? Программа использует при запуске файл Njwin.ini , расположенный в каталоге Windows. Значит, следует трассировать изменения, происходящие при чте- нии .ini файла. Ставим bpx GetPrivateProfileString и запускаем программу. Останавливаемся мы в следую- щем месте:


 0001.3B83 9AB93B0000 call KERNEL.GETPRIVATEPROFILESTRING
 0001.3B88 80BEF6FD3F cmp byte ptr [bp+FDF6], 3F
 0001.3B8D 752E jne 3BBD
 0001.3B8F FF36DC05 push word ptr [05DC]
 0001.3B93 FF36DA05 push word ptr [05DA]
 0001.3B97 FF36E005 push word ptr [05E0]
 0001.3B9B FF36DE05 push word ptr [05DE]
 0001.3B9F FFB6ECFB push word ptr [bp+FBEC]
 0001.3BA3 FFB6EAFB push word ptr [bp+FBEA]
 0001.3BA7 8D86F6FD lea ax, [bp+FDF6]
 0001.3BAB 16 push ss
 0001.3BAC 50 push ax
 0001.3BAD 680001 push 0100
 0001.3BB0 FF36F405 push word ptr [05F4]
 0001.3BB4 FF36F205 push word ptr [05F2]
 0001.3BB8 9AE53B0000 call KERNEL.GETPRIVATEPROFILESTRING
 0001.3BBD FF36DC05 push word ptr [05DC]
 

Трассируем программу, пока не дойдем до следующего места:


 0001.33EB 9AFA360334 call 0001.36FA вызов считывания данных из реестра
 0001.33F0 83C402 add sp, 0002
 0001.33F3 0BC0 or ax, ax
 0001.33F5 7503 jne 33FA проверка на регистрацию
 0001.33F7 E9BF01 jmp 35B9 переход, если зарегистрирована
 0001.33FA FF36F005 push word ptr [05F0]
 0001.33FE FF36EE05 push word ptr [05EE]
 0001.3402 680934 push SEG ADDR of Segment 0001.
 

Как видно, по адресу 001.33F5 осуществляется проверка регистра ах, с последующим переходом через адрес 0001.33F7, если программа не зарегистрирована. Значит, нам необходимо изменить jne 33FA на jmp 35B9 - и CRACK готов.




Исследование Offline Explorer 2.2.807

Автор: Wersion (Abetkin Veaceslav)
WEB сайт: http://expwinprg.cjb.net

Не ошибитесь версией!

Tools:

  • TRW 2000/Softice-сами думайте как делать в нём то же самое;
  • RESHACKER/ЛЮБОЙ РЕДАКТОР РЕСУРСОВ;
  • WIN32 DASM;
  • PROCDUMP 32;
  • HIEW 6.55/any other Hex Editor;
  • Extreme Loader Generator v0.3/что-нибудь подобное;
  • Import Reconstructor/Revirgin/руки и голова;

Если вы желаете только получить взломанную версию программы – вон отсюда(крестик в правом верхнем углу экрана, 1 раз щёлкнуть левой кнопкой мыши); Всё написанное предназначено только для образовательных целей. Написанное потому, что на пиратских сайтах давным-давно есть крэки к этой замечательной программе L, потому, что это 10-я взломанная мной программа.

Ну что, начнём. Запускаем oesetup.exe, создает ярлык на Desktop’е. Щёлкаем, смотрим. Какая большая, красивая программа. Есть Nag, 30-day limitation, ограничений функциональности не заметил.

Смотрим размер файла – маловат, 831 kb. Кажется, запаковали. Суём в Reshacker\Restorator – всё corrupted. Точно.сжато. Лезем в ProcDump, выбираем PE editor->наш файл.

Имена секций не снесли, значит, скорее всего, только запаковали. Смотрим дальше. Привлекла меня секция .daat. Не видел, чтобы при компиляции делали такие секции. Это секция распаковщика. Ставим ей E0000020 в Section Characteristics. (Мера, в основном, для Softice’a), почему – читай формат PE, таблицу Dr.Golova. Запускаем TRW 2000, Load->цель. И F5/X-выход в Windows. Зачем трассировать весь распаковщик?

Итак, программа запущена, перед нами Nag. Мне понравилось слово ‘evaluation’ на нём. Поищем его в памяти. Ctrl-n/m, активизируем TRW 2000. Команда s 30:0 ffffffff ‘evaluation’. Нам говорят:


 59412d in OE!CODE+19312D. F5/X . Закрываем OE.exe; снова Load->цель.
 

Cтавим брейкпоинт на этот адрес в памяти:


 bpm 59412d w .
 

Нажимаем F5/X. вываливаемся в TRW 2000 на инструкции


 REP MOVSD
 {****}
 REP MOVSB
 POP ESI
 {****}
 CALL XXXXXXXX
 {*********}
 JNZ XXXXXXXX
 

пройдите их всех по F10 до JNZ т.к. ХХХХХХХХ, на который он собирается прыгнуть меньше того, на котором мы стоим, то мы его обойдём.

Ставим брейкпоинт на следующую за ним строчку(F9); Затем F5; F9(снять брейкпоинт) и продолжаем трассировку. Аналогично обходим все подобные JZ/JNZ/JMP. Когда увидите инструкцию POPA, встанете на RET, нажмите F10 последний раз. Всё! Распаковка закончилась! Мы в программе, в секции CODE.

Запишем EIP на бумагу. Введём команду suspend. Ничего не закрываем и запускаем Procdump.

В Options оставляем только Recompute Object Size и Use actual import infos. Сделаем Dump(Full) нашего процесса.

Убьём его. Выйдем из Trw 2000. Опять в ProcDump->PE editor->Our_dump.exe

Нужно выставить ему правильную Entry Point. Она равняется EIP-Image Base. И то и другое нам известно. Для меня EIP=005F0E7, Image Base=0400000. Посчитайте в Калькуляторе от Microsoft(Hex mode). (У меня получилось 001F0E7C). Теперь поставьте всем секциям E0000020. //дамп уже запускается и распакован!

Дальше нужно восстановить таблицу импортов (хотя можно ломать и так). Можно использовать Import Reconstructor/Revirgin/руки и голову;

Я выбрал 3-е, а потом 1-е. И так и этак получается замечательно.

Через 1-е: смотрим RVA и *Size секции .idata пишем в IAT Infos. Жмём Get imports и Fix Dump. (прислушаемся к сообщению и исправим Procdump->Directory->Import Table на соответствующие параметры новой секции); Через 3-е: //долго рассказывать

Теперь самое главное. Суём всё это в Win32 Dasm. И пока он работает, запускаем Oe.exe и смотрим раздел, посвящённый регистрации. На неправильный код программа отвечает сообщением ‘Sorry…’. Вот мы и поищем его в дизассемблированном файле. (Search->Find Text); Со 2-го раза нашли:


 * Referenced by a (U)nconditional or (C)onditional Jump at Address: // Вот
 откуда мы прыгаем на эту гадость!
 
 |:005997BB(C)
 {Много пропущено}
 |
 * Possible StringData Ref from Code Obj ->"Sorry, registration information "
 ->"is invalid."
 |
 :00599878 BAE8985900 mov edx, 005998E8
 :0059987D A108BD5F00 mov eax, dword ptr [005FBD08]
 :00599882 8B00 mov eax, dword ptr [eax]
 :00599884 E8F3E0EBFF call 0045797C
 

Идём на 005997BB:


 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0059969E(C) // а это в свою очередь отсюда;
 |
 :005997B2 8B07 mov eax, dword ptr [edi]
 :005997B4 80B86407000000 cmp byte ptr [eax+00000764], 00
 :005997BB 7420 je 005997DD
 

Идём на 0059969E:


 :00599697 E848FC0300 call 005D92E4 {проверяем РН}
 :0059969C 84C0 test al, al {если неверен то в al должно быть 0}
 :0059969E 0F840E010000 je 005997B2{если al=0 то прыгаем на сообщение о
 неверности РН}
 

Ну что, зайдём в этот call 005D92E4 : Вот что он делает:


 * Referenced by a CALL at Addresses:
 
 |:00599697 , :005DF5CE {Оказывается, не только из 00599697 вызывается}
 |
 :005D92E4 8BC2 mov eax, edx {Здесь с al ничего не делают}
 :005D92E6 8BD1 mov edx, ecx {и здесь тоже}
 :005D92E8 E86BF6FFFF call 005D8958{а этот должен работать с Al}
 :005D92ED C3 ret {выход из процедуры/функции}
 

Видно, что процедура проверки вызывается несколько раз. Программа, вероятно, использует её при старте, чтобы определить, показывать Nag или нет. Нужно сделать так, чтобы после выполнения нашего call 005D92E4 в AL было 1. С этим с успехом справится команда mov AL,1. Её можно записать вместо call 005D8958 по адресу 005D92E8.

Воспользуемся Hiew 6.55. Откроем файл, F5, .005D92E8,,F3,F2. Пишем. Т.К. в Hex’е наша инструкция-B001, call 005D8958- E86BF6FFFF то оставшиеся байты (после B001 и до C3) надо забить Nop’ами(90). Сохраняем (F9), выходим (F10).

Запускаем. Ура! Ни Nag’a, ни надписи NOT REGISTERED в About. Никаких ограничений!

Хотя мы не имеем прав распространять взломанную программу, этикет требует сделать для неё что-то типа патча. Чем и займёмся. Конечно, всё это можно сунуть в архив, добавить *.nfo и показывать как своё геройство.

(Так сделал TSRH; кстати, как ему не стыдно распространять Cracked Exe и гадить производителям?). Но! Мы сделаем вещь поменьше и покрасивее и не будем никому давать.

Изучив работу распаковщика, я понял, что это что-то многослойное, похожее на AsPack. Патчить его трудновато. Создадим загрузчик. Я пытался использовать R!SC Process Patcher, но он почему-то не работал, или заменял байты рано/поздно. Аналогично Patch Creation Wizard->Memory Patch. Взял PELG(Extreme Loader Generator). Тоже не работает.

Что ж, опять в отладчик->Load->PackedOe.exe bpx 005D92E4 //Адрес, который вызывал наш call <проверка РН>. F5/X.

Появляется Splash, чуть–чуть висит, а затем мы вываливаемся в TRW 2000. Понятно. Проверка рановато происходит, ещё при Splash’е.

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

В PELG’е есть Method of detection [Standard, Window Title, Class Name]. Standard, как я говорил, не работает, Window Title у Splash’а не наблюдается, остаётся Class Name. А его где взять? Splash показался, исчез и в списке не значится. Притормозим программу.

Отладчик->Load->PackedOe.exe


 bpx 005D92E4 //Адрес, который вызывал наш call <проверка РН>.
 F5/X.
 suspend
 
 В PELG’е->Refresh.
 Вот он, TdlgSplash !!! Выбираем его.
 Ctrl-n, отпускаем жертву;
 PELG->Add (RVA, New bytes);
 RVA=5D92E8 (см. выше).
 New bytes=B001 + Nop’ы=B001909090 (см. выше).
 PELG->Program Info->FileName=Oe.exe
 PELG->Cracker Name=wersion
 PELG->Create Loader;
 

Сделано!

Комментарии:


 s 30:0 ffffff ‘string’
 s=search;
 30:0 ffffffff=область поиска, здесь – вся память.
 ‘string’– строка.
 bpm xxxxxx = брейкпоинт на область памяти. w/r – запись/чтение.
 bpx xxxxxx = брейкпоинт на адрес в программе.
 suspend – зациклить процесс.
 

Greats to: Dr. Golova, Predator, G-Rom, Lorian&Stone, Sen, MackT/ uCF2000 and many others!

Пишите, если что-то непонятно и только по серьёзным вопросам.




Распаковка PC guard в ListMate Pro Demo

Автор: Hex

Инструменты: Softice, Icedump, Hex Workshop, ProcDump.

Про PC guard я не видел туториалов, по этому напишу сам. В ListMate тут идет довольно старая версия PC guard. Как написано в pcgw32.dll:


 PCGW32.DLL (c) 1998/1999 by Blagoje Ceklic all rights reserved
 

Но прога Listmate идет от 2002 года. Так что можно сказать ломаем новое :). Тем более все эти раскриптовщики для PC guard не берут его... прям даже странно... Где же обратная совместимость?

Ну ничего страшного. Сначала запускаем Icedump, без него Listmate ваще не запускается, сечет айс зараза. Для начала получим oep и снимем дамп. Можно сделать /tracex 400000 4E0000 и подождать минут 20. А можно потрейсить(F8) от окна, которое выводит PCGuard, и минут через 5 тоже прийти к энтрипоинту по адресу 4A305C. Снимаем дамп (icedump). Потом в Hex workshop'e копируем PE от закриптованного файла и ставим его вместо заголовка нашего дампа. Procdump'om делаем в дампе стандартную процедуру Physical Size:=Virtual Size и Offset:=RVA, для всех секций. Ресурсы сразу станут на место и у нашего дампа появится иконка. Дальше остается испорченый импорт. Не пытайтесь восстанавливать через ImpRec и Revirgin! Портится окончательно :( Я давно заметил что они как-то глючно импорт восстанавливают. А тут они вобще все к черту портят. Тут делаем не так... Запускаем наш дамп. Он глюканет. Разберемся где оно глюканет. Как раз на импорте, будет jmp [4b1xxx]. Это как раз импорт. Советую прочесть про импорт на reversing.net в статьях. Дальше просматриваем память вверх от этого 4В1xxx. И находим что импорт начинается с 4B1000 и его длина 12С. Пишем эти данные в Import table (Directory) юзая Procdump. Если глянуть на эту таблицу то становится видно что из нее специально вытерты все имена функций и DLL. Похоже PC Guard это делает сам "вручную". Это можно легко проверить. Ставим BPM 4B1000. Запустив Listmate получаем облом - PC Guard блокирует BPM. И кидает нас на код такого рода:


 MOV DR3, EAX <-тут выдает ошибку
 MOV DR5, EAX
 MOV DR6, EAX
 MOV DR7, EAX
 NOT ESP
 NOT ESP
 NEG ESP
 NEG ESP
 INC ESP
 DEC ESP
 POPAD
 POPFD
 MOV [EDX],CH
 

Обойти это дело очень просто нужно просто EIP поменять на адрес команды MOV [EDX],CH. И прога пойдет дальше. Сработает BPM. Посмотрим нашу таблицу... Имена есть! Но она обраывается по адресу 4B2000. Делаем BPB 4B2000. Когда сработает BPM 4B2000, то имена в блоке до адреса 4B2000 будут уже затерты. Но после 4B2000 мы увидим продолжение таблицы с заполнеными именами, которая теперь оборвется по адресу 4B3000. Ну тут уже и ежу понятно, что дальще будет тоже самое. BPM 4B3000 и видим последний кусок. Теперь перезапустим прогу и просто по кусочкам сохраним наши блоки по мере того как они заполнены функциями. А потом соеденим их в Hex workshop. Теперь у нас есть заполненная таблица импорта. Осталось только заменить таблицу импорта и все. Заменяем и радуемся распакованной прогой. Дальше там уже DEDE в руки и делаем из Demo - полную.

P.S. Сочитание дурацкое какое-то "Pro Demo". Тут уж или про или демо...




Протекторы и упаковщики

Автор: Hex

Запихнув в windasm упакованную программу, начинающие делают квадратные глаза типа: "А.. эээ чо это такое?". Поговорим о упакованых прогах.

Написание прог большого размера конецчно же привело людей к мысли: "А не сжать ли это?". Когда нужно просто хранить прогу, то ее сжимают архиватором. А вот когда нужно сжать прогу и чтобы она разжималась в память юзают упаковщики. Т.е. прога становится считай что sfx архив, тока разархивация происходит в память, а не надиск. Естественно, если такой файл запихнуть в дизассемблер то кода проги явно не увидишь, это тоже самое что попытаться открыть вордом rar архив в котором лежит doc файл. Сначала разжать надо, а потом пихать в дизассемблер. Сначала когда упаковка была просто средством для уменьшения размера exe файла, сама прога упаковщик позволяла разжать упакованый ею файл. Но народ сразу понял, что упаковкой можно прятать код. Т.е. в дизассемблере реальный код не увидишь пока не распакуешь. Вот и начали делать упаковщики которые тока пакуют. Ну крэкеры тоже не тупые. Нету распаковщика - и не надо. Распаковать файл можно и вручную. Берется дебагер и спомощью него проходится весь распаковывающий кусок кода(распаковщик). В конце такого кода идет переход на Entry point оригинальной не упакованной проги. Тут нужно остановиться снять дамп. Т.е. дапм памяти будет соответсвовать распакованой программе, т.е. программе которая была вначале, до упаковки. Потом дампу ставят правильный Entry point, он явно виден в конце любого распаковщика. И получают практически одинаковую с оригинальной прогу. Программерам такой расклад не понравился. Толку от такой упаковки, если любой ламер с дебагером и дампером за 5 минут все на место поставит. И начались подлости и пакости. Одной из первых пакостей стала порча таблицы импорта. Заключалось это в том, что таблица импорта содержит имена функций и dll, по которым потом берутся адреса и создается IAT, так вот в упаковщик впихнули код который затирал эти имена. Т.е. IAT оставалось, а имен нету. Естественно дамп получался нерабочий. Крэкеры фишку просекли и начали ставить брейк поинты на функции которые могут испортить таблицу импорта, и без проблем все это дело обломали. Вот тут началась эра протекторов. Програмеры поняли что надо отобрать у крэкеров ихние любимые инструменты или сделать так, что с этими инструментами крэкерам было б очень тяжело отслеживать, то что происходит. Т.е. код распаковщика начали делать полиморфным. Потом начали вставлять антитрассировочный и антидебаговый код. И начались разные смеси полиморфных распаковщиков с разными приемами обнаружения дебагеров + код который создает IAT "вручную"(т.е. таблица импорта вобще не существует). Например Pcguard, tElock. Но крэкеры тоже руки сложе не сидели, сделали проги для прятанья дебагеров(icedump и frogsice) и проги для восстановления импорта по IAT(revirgin, imprec). Думаете на этом все заканчивается? Нееет это было тока 3 года назад. А щас все гораздо интереснее. Программеры нашли новыем методы обнаружения отладчиков которым плевать на icedump и frogsice. Потом началось клепания протекторов, которые забирают часть кода проги в себя. Т.е. отодрав протектор выходит не полный дамп, пусть даже и с правильным импортом. Это к примеру SVKP, ASProtect и Activemark. Код проги начали криптовать. Причем криптовать по извратному. Например Asprotect в зависимости от регистрационного ключа по разному распаковывает прогу. И последнее извращение - распаковщик на собственной виртуальной машине. Т.е. такой распаковщик выполняет псевдокод и контролировать его просто нереально. Это защита StarForce.

Вот такие пироги. Ты рад что ты сюда сунулся? Готов к гиморою? :) Не боись! Прорвемся! :) Казаки и Демиурги крэкеры сломали, reget тоже сломали. Все у нас получится :)




Футбол чемпионат мира 2002 от Snowball и 1C - Пример взлома CD

Автор: Fess

- Люблю горячие блины! - сказал программер, вытаскивая только что записанный диск из CD Writerа.

Target: Футбол чемпионат мира 2002

Tools:

  • Some brains
  • Win32Dasm 8.93
  • Все, кроме мозгов, можно найти на www.exetools.com

Вступление

Как это начиналось:

Дали мне тут гамес с привязкой и я решил его пощупать. Почему в топике я написал про SnowBall и 1C? На это есть две объективные причины. Первая, я уже играл в чемпионат мира 2002 от другой фирмы и гам был другой. Вторая, игры от 1С никогда не славились своей защитой, поэтому взлом будет простым.

Начало

В каталоге, я обнаружил 3 exe файла. Проведем эксперимент, в каком же из них содержится нужная нам функция GetDriveTypeA. Запускаем любой нормальный файл-менеджер (я юзаю DosNavigator или его клоны). Нажимаем Atl-F7 пишем искать в файлы *.exe, содержащие строку GetDriveTypeA. Нашелся один файл с названием PSC2002.exe.

Суем его в Win32Dasm и ждем. Затем переходим к месту вызова этой функции и оказываемся здесь.


 :004877EC 55            push ebp
 
 * Reference To: KERNEL32.GetDriveTypeA, Ord:0104h
                                   |
 :004877ED FF1558C04B00  Call dword ptr [004BC058]
 :004877F3 83F805        cmp eax, 00000005
 :004877F6 0F85B7000000  jne 004878B3
 .......
 :0048780A 50            push eax
 :0048780B 55            push ebp
 
 * Reference To: KERNEL32.GetDiskFreeSpaceExA, Ord:0101h
                                   |
 :0048780C FF1590C04B00  Call dword ptr [004BC090]
 :00487812 85C0          test eax, eax
 :00487814 0F8499000000  je 004878B3
 .......
 :004878D8 5D            pop ebp
 :004878D9 B001          mov al, 01
 :004878DB 5B            pop ebx
 :004878DC 81C434020000  add esp, 00000234
 :004878E2 C3            ret
 

Как видно из листинга, Здесь помимо стандартной проверки на CD-ROMность, применяется проверка на наличие свободного места на диске (без сомнения в фирмах работают "продвинутые" программеры). Можно, конечно, менять переходы после них. Но я сделал более удобный и быстрый вариант. Вы без сомнения заметили выделенную строку, которая возвращает результат проверки. Т.е. стоит нам в начале процедуры (которая начинается с 4877B0) написать mov al, 1; ret, то все проблемы увянут сами собой. Так и поступим, заходим в любой hex-редактор и начиная с 487B0 пишем такие байтики B0 01 C3. Которые являются hex-представлением этих команд и все в порядке.

Запускаем... все рулит. Итак мы рульные хацкеры поломали корявую защиту. Ура нам! Ура!

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

Послесловие

Господа Авторы: защита фигня, если хотите, чтобы за прогу платили баблосы - делайте защиту лучше.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Взлом без знания Assemblera - Сократ персональный 4.1

Автор: Fess

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

Target: Сократ персональный 4.1

Tools:

  • Install Shield script decompiler 1.00 by NEKOSUKI (isd.exe)
  • Some brains
  • Сократ Интернет 99
  • Ключ к Сократ Интернет 99
  • Любой фаловый менеджер (типа DN, NC, Far)

Вот решил написать об одном интересном трюке применненном мной к программе "Сократ персональный 4.1". Мы сломаем ее СОВСЕМ без использования ассемблера, в смысле заставим работать без ограничений, т.е. зарегистрируем ее, а не сломаем, чтоб не работала. Купил вот на днях диск "Переводчики" и журнал ПЛ 02.2002. На компакте журнала оказалась эта замечательная программа, но ShareWare, т.е. заплати бабки и работай спокойно, а на компакте "Переводчики" Сократ Интернет с ключем SI-YPC73AYRC3BD.

Не долго думая, я запустил Персональный набрал код, и... обламался, не выгорело. Тут я крепко задумался, для проверки пароля в Install Shield используется написанная разработчиком, т.е. компанией Арсенал библиотека. Но все это замудровано в установщике и поэтому так просто не видать. Делаем нижеследующее запускаем инсталяцию доходим до шага перед проверки пароля. Идем в каталог WINDOWS\TEMP там должен быть еще один каталог с каким нибудь названием. В нем находится несколько библиотек, т.е. файлов dll и другие файлы скопируйте их все в другой каталог, например, С:\MUSOR. Смотрим внимательно, открываем каждую библиотеку просмотрщиком к разделу экспорта это где-то обычно ближе к концу и ищем подозрительные строки (названия экспортируемых функций). В файле di_set32.dll мы обнаружили строки GetLongSN и GetShortSN. Аббривиатура SN напомнила нам магические слова Serial Number. Значит это то, что надо.

Теперь запускаем инсталяцию Сократ Интернет 99 опять идем в TEMP и копируем оттуда уже знакомый нам di_set32.dll в каталог MUSOR предва- рительно переименовав его в di_set32.dl_ смотрим в него, вроде функции те же, размер такой же, только функция проверки ключа другая. И тут к нам приходит гениальная мысль заменить одну dll-ку другой предварительно поменяв у di_set32.dl_ дату и время в соответствии с исходной. Опять запускаем установку заменяем в TEMP библиотеку, но что-то опять не работает и пароль не принимается. Много раз введя пароль нам бросаются на глаза две первые буквы SI. Ооо. Логично, что это от Socrat Internet, значит Сократ персональный SP запускаем, опять не прошло. Да что же такое.

Пришло время серьезных действий копируем в каталог с файлом isd.exe файл setup.inx в котором содержиться весь план инсталяции. Набираем isd.exe setup.inx, запускаем, ждем, получаем файл isd_dec.txt. Но что в нем искать, опять идет в каталог MUSOR и ищем файл, в котором содержатся все сокращения строк, а именно нам надо найти строку "Установить Демонстрационную версию?". Находим в файле value.shl она приравнивается MSG_DEMO, хорошо ищем MSG_DEMO в файле isd_dec.txt, есть контакт, нашли, но вокруг ничего интересного, это кажись какие повторяем поиск, еще одна теперь вокруг незнакомых операторов, больше совпадений нет, т.е. строка одна. Смотрим выше в голове туман, одна надежда выглядеть что-нибудь интересное, строчек восемь вверх и мы видим текстовыю строку n0003 = s0002 != 'SX'. Строка SX нам, что-то напоминает и мы начинаем копаться в грудах листов на столе, ничего не найдя идем на кухню ставить кофе, не заменив стукаемя головой об косяк и на нас снисходит озарении. Это ж наверное, надо было писать SX, а не SP (мне тут подсказывают, что если б я порылся в бумажках подольше я бы узнал, что знак != это не равно, ну да ладно). Повторяем процедуру установки, копирования dll-ки, набиранием пароля вместо SI, написав SX Пошло каково же было наше счастье. Но и это еще не все.

По окончании установки мы пытаемся запустить Сократ, но выдается какая-то ошибка, и тут опять озарение (шишка еще не прошла) надо наш файл di_set32.dl_ в каталог с установленной программой, переименовав его в di_set32.dll и, заменив тем самым плохой, пуск... Моменты ожидания, но все работает!!! Ура! Рулез!! Стираем не нужный теперь каталог MUSOR и другие не нужные файлы.

Вот так без знания асма можно ломануть программу

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Symantec pcAnywhere v9.0.0 build 133. Защита в DLL.

Умный программист всегда сумеет занять компьютер глупой работой.

Эта программа, которой я пользуюсь уже давно, предназначена для связи, обмена файлами и удаленного управления между компьютерами практически по любому соединению и протоколу. Скопировать pcAnywhere можно на сайте фирмы Symantec.

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

Итак, перед нами стоит задача избавиться от 30-ти дневного ограничения времени , и попутно убрать диалоговое окно, возникающее при запусмке программы, и сообщающее о том, что это trial-версия.

Открываем файл Winaw32.exe в WinDASM. Попытки найти что-нибудь, имеющее отношение к проверкам времени, ни к чему ни приведут. Тогда давайте нажмем на кнопочку "Imported Functions" (импортируемые функции), и посмотрим появившийся список. Лично меня очень заинтриговала следующая функция: TimeBombCheck(). Название навевает интересные мысли… Дважды нажав на эту надпись, мы попадем в то место, откуда эта функция вызывается:


 :00406112 FF1524814500		Call dword ptr [00458124]
 :00406118 85C0			test eax, eax
 :0040611A 7509			jne 00406125
 :0040611C 5F			pop edi
 :0040611D 5E			pop esi
 :0040611E 81C498000000		add esp, 00000098
 :00406124 C3			ret
 

Теперь загрузим программу в SoftICE, поставим контрольную точку на строчку, где вызывается функция (bpx 00406112), и запустим программу. Попав в SoftICE, щелкнем мышью на строчку ниже (test eax,eax), и нажмем F7. Мы увидим уже знакомое нам окно, и, после нажатия в нем кнопки, возвращаемся в SoftICE. Обратите внимание на содержимое регистра ЕАХ – если срок работы программы еще не вышел, оно отлично от нуля. Казалось бы чего проще – поменять JNE на JMP – и все. Попробуйте…

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

Правильнее будет посмотреть в Awcomm32.dll, и заставить эту функцию всегда возвращать в регистре ЕАХ единицу. К тому-же в этой же процедуре находятся и вызовы окон об окончании периода работы и т.д., от которых тоже было бы неплохо избавиться – лично мне они очень мешают.

Опять берем WinDASM, и загружаем в него Awcomm32.dll. Находим эту функцию:


 Exported fn(): _TimeBombCheck@4 - Ord:00CCh
 :67EA3800 81EC08020000		sub esp, 00000208
 :67EA3806 53			push ebx
 :67EA3807 55			push ebp
 :67EA3808 56			push esi
 :67EA3809 57			push edi
  ...	  ...			...
 

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


 * Reference To: ISCUSTOM.?TimebombVer@CTBombCache@@QAEXAAG0@Z, Ord:0011h
 				|
 :67EA3A42 FF15E400EB67		Call dword ptr [67EB00E4]
 :67EA3A48 33C0			xor eax, eax
 :67EA3A4A 8B4C2434		mov ecx, dword ptr [esp+34]
 :67EA3A4E 8B542418		mov edx, dword ptr [esp+18]
 :67EA3A52 66A1EE8EEB67		mov ax, word ptr [67EB8EEE]
 :67EA3A58 81E1FFFF0000		and ecx, 0000FFFF
 :67EA3A5E 51			push ecx
 :67EA3A5F 81E2FFFF0000		and edx, 0000FFFF
 :67EA3A65 33C9			xor ecx, ecx
 :67EA3A67 52			push edx
 :67EA3A68 668B0DEC8EEB67 	mov cx, word ptr [67EB8EEC]
 :67EA3A6F 50			push eax
 :67EA3A70 51			push ecx
 :67EA3A71 E82AFCFFFF		call 67EA36A0
 :67EA3A76 83F8FF		cmp eax, FFFFFFFF
 :67EA3A79 0F8492010000		je 67EA3C11
 :67EA3A7F 85C0			test eax, eax
 :67EA3A81 745A			je 67EA3ADD
 :67EA3A83 83F801		cmp eax, 00000001
 :67EA3A86 7427			je 67EA3AAF
 

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

Почему именно это место? Если внимательно просмотреть выполнение этой функции, то мы увидим, что в ней идет двойная проверка: сначала делается проверка "легальности" и времени, и, если программа "зарегистрированна", то значение ЕАХ будет равно единице, и, после сравнения в вышеуказанном месте, происходит простой переход на конец проверки. Если же это trial-программа, то в регистре ЕАХ будет ноль, и происходит переход на вторую ветвь, в которой осуществляется еще одна проверка времени, и либо закрытие программы, либо продолжение выполнения.

Итак, наши изменения сводятся к следующему:


 test eax,eax
 je 67EA3ADD
 

заменяем на


 xor eax,eax	- обнуление регистра ЕАХ (на всякий случай)
 mov al,01	- запись в ЕАХ единицы (используется регистр AL для соблюдения
 		  количества байт)
 

Изменяем и запускаем… Все прекрасно работает, никаких мешающих окон и временных ограничений.

Это не первая версия pcAnywhere, которую я исследую. Честно говоря, я думал, что Symantec придумает что-нибудь посерьезнее (взять хотя бы их TalkWorks – солидная защита). А здесь на лицо элементарные ошибки: нельзя защиту помещать в DLL – тогла ее отключить намного проще, чем защиту, включенную в сам исполняемый файл, потому что явно виден результат работы вызываемой функции проверки.

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




TabMail v2.2 или не стоит отчаиваться

Автор: Fess

Во время посещения России Билл Гейтс прошел курс лечения у известного российского сексопатолога. Эффект от лечения был таков, что он решил сменить название своей фирмы на Гиперхард.

Target: TabMail v2.2 (Build 15.12)

Tools:

  • Some brains
  • Soft-Ice 3.24
  • Win32Dasm 8.93
  • PEIdentifier 0.7
  • Упаковщик UPX
  • Любой hex+asm-редактор (я использую QView)

Пролог

Вступление:

Делать было нечего и я решил, что-нибудь поломать. Полез по дискам с шароварой и на диске Hard&Soft'a не помню, какой номер. Чуть-чуть ее по- ковыряв, я понял, что программа проста для взлома. Хотя, кой-какие момен- ты есть.

Что за прога:

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

Примечание:

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

Вступление

Программа будет взломана двумя способами:

1) Подсмотр кода
2) Написание кейгена на основе самой программы

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

Подсмотр кода

Первое, что надо сделать это посмотреть запакована ли программа. Если Да, то чем для этого я использую программу PEIdentifier. Запускаем и видим UPX 0.89.6 - 1.02 / 1.05 - 1.20 -> Markus & Lazlo. Ага, UPX это хорошо, он очень хорошо распаковывается самим UPX'ом. Если его запустить с ключем -d. Распаковываем и суем его в Win32Dasm, который выдает нужный код, но зайдя в секцию строк мы не видим нишиша. Наверно, программа сбацана на Delphi, если засунуть в PeId уже распакованную программу, мы поймем, что так оно и есть.

Ну что ж, будем опираться только на себя, да на SoftIce. Запускаем про- гу и ищем, где бы нам ввести код. Сразу после запуска мы видим великолеп- ный nag-screen с кнопкой Register. Жмем ее и видим форму, где и вводим, например, такую фигню Name: FessCool Code: 110022334455. Запускаем и видим сообщение, об ошибочности наших действий, с рульной иконкой. Хе-хе-хе, зря, товарисчи, вы так делаете, зря. С давних времен известно, что делфи не ис- пользует мессагубоха, а вот LoadIconA использует вполне. Ставим бряк на это и о кул, при повторной попытке мы вываливаемся в прогу. Место, где мы выва- лились не очень понятно, но дадим такую команду s 0 l -1 "110022334455". У меня строка нашлась на 11E7F48. Удаляем не нужный теперь бряк bc*. И ставим бряк на bpmb 11E7F48 rw. Еще раз запускаем процедуру регистрации, вывалива- емся нажимаем несколько раз F12, пока не вываливаемся в таком месте.


 :0047A343 8B45FC        mov eax, dword ptr [ebp-04]
 :0047A346 50            push eax
 :0047A347 8D55F0        lea edx, dword ptr [ebp-10]
 :0047A34A 8B83F0010000  mov eax, dword ptr [ebx+000001F0]
 :0047A350 E843BCFEFF    call 00465F98
 :0047A355 8B55F0        mov edx, dword ptr [ebp-10]
 :0047A358 8D45F4        lea eax, dword ptr [ebp-0C]
 :0047A35B E8DC99F8FF    call 00403D3C
 :0047A360 8B45F4        mov eax, dword ptr [ebp-0C] <- В eax имя
 :0047A363 5A            pop edx  <- в edx код
 :0047A364 E873FFFFFF    call 0047A2DC <- Процедура проверки
 :0047A369 84C0          test al, al
 :0047A36B 7413          je 0047A380
 

Видно, что выделенная процедура, это скорее всего процедура проверки ко- да, и test al,al это проверка все Ок, или Нет. Заходим в процедуру, нажимая кнопку F8. И видим следующий код


 :0047A2E4 E88B9AF8FF   call 00403D74
 :0047A2E9 83F808       cmp eax, 00000008
 :0047A2EC 7E15         jle 0047A303
 :0047A2EE 8B158CE04B00 mov edx, dword ptr [004BE08C]
 :0047A2F4 8B12         mov edx, dword ptr [edx]
 :0047A2F6 8BCE         mov ecx, esi
 :0047A2F8 8BC3         mov eax, ebx
 :0047A2FA E891FCFFFF   call 00479F90
 :0047A2FF 84C0         test al, al
 :0047A301 7505         jne 0047A308
 

Мы видим, что это сравнение на длинну имени. Странно нигде об этом не предупреждалось?!!! Ну да ладно вводим такое имя: FessCool2002. И начинаем заново трассировать, проходим проверку и заходим в процедуру call 00479F90. И трассируем до тех пор, пока не увидим следующий код...


 :0047A018 8B55F4     mov edx, dword ptr [ebp-0C]
 :0047A01B 8B45FC     mov eax, dword ptr [ebp-04]
 :0047A01E E851EAFFFF call 00478A74
 :0047A023 8BD8       mov ebx, eax
 :0047A025 33C0       xor eax, eax
 

Здесь по адресу edx можно посмотреть настоящий код. Как я это угадал? Все просто, как в детстве, тут просто нужно упорство. Я трассировал и смотрел на изменяющиеся регистры, пока не нашел этот. На имя FessCool2002 это код 664d8cad-751e7eb5-86cb2621-00f3541f.

Написание кейгена на основе самой программы

Так код мы подсмотрели, теперь осталось написать кейген, это не просто, а очень просто. Делать это будем используя MessageBoxA, как я обычно и де- лаю.

Ищем любой вызов процедуры MessageBoxA в листинге Win32Dasm. Вот первый


 :00426272 50         push eax
 :00426273 57         push edi
 :00426274 56         push esi
 :00426275 8B4324     mov eax, dword ptr [ebx+24]
 :00426278 50         push eax
 
 * Reference To: user32.MessageBoxA, Ord:0000h
                         |
 :00426279 E82E03FEFF Call 004065AC
 

Так процедура вызывается из 4065AC посмотрим, что там


 * Reference To: user32.MessageBoxA, Ord:0000h
                           |
 :004065AC FF253C164C00 Jmp dword ptr [004C163C]
 

Хорошо. Теперь попробуем найти по коду эту строку в самом файле, т.е. ищем FF253C164C00, одна единственная и нашлась по адресу 59AC. Теперь ос- талось начиная со строки 47A01B написать вызов, функции MessageBoxA. Дела- ем это так, заходим в QView и ищем строку hex-кода E851EAFFFF8BD8. У меня она обнаружилась на 7941B теперь начиная с этого адреса вписываем такие строки (через тире представлены их hex представление)


   push 0    - 6A00
   push edx  - 52
   push edx  - 52
   push 0    - 6A00
   call 59AC - E886C5F8FF
   nop       - 90

Теперь запускаем программу, вписываем свое имя и в МессагаБоксе видим нужный код. Вот это кул. Но теперь, если вы попробуете еще раз зарегиться на другое имя, то вам придется удалить параметр RegUserName из ключа ре- естра HKCU\SOFTWARE\DLG\TabMail, там же в параметре RegCode, можно видеть, введенный вами код, но это код который вы ввели просто так, а не настоящий так, что вот еще один метод, так сказать нахождение ключа и патч в одном флаконе.

Послесловие

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

Хочу надеяться, что эта статья Вас чему-либо научила и помогла в осво- ении этой нелегкой науки.

Крэкеры, крякеры и кракерята, сказать практически нечего разве, что только не ругайте сильно разработчиков за такую корявую защиту.

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

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Распаковка и восстановление файлов упакованых tElock 0.98

Автор: Hex

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

Инструменты: Softice, IceDump, Imprec.

Как найти OEP: bpx GetModulehandleA, потом /tracex imagebase xxxxxx , где xxxxxx число примерно пониже базы распаковщика.

А вот с импортом не все так просто. Взяв Imprec будет сразу видно что 2 секции никак не востанавливаются. И элементы этих секций указывают на какие-то разные области памяти, даже не в области упаковщика. Если глянуть в эти области, то нас постигает огромный облом... Некоторые элементы указывают в пустые куски памяти (те что с ?? ?? ...), а остальные указывают на вызовы процедур из библиотек через полиморфные куски кода!!! Хана... Это ж даже не подизасмишь. Но выход есть! Берем к примеру первый не найденый элемент к примеру 5b140 ссылается на 700000. Смотрим на код по адресу 700000. Он имеет вид:


 0167:00700000 JMP 00700005
 0167:00700002 JMP EBX
 0167:00700004 INVALID
 0167:00700006 NOP
 0167:00700007 PUSH ES
 0167:00700008 JO 0070000A
 0167:0070000A INC EAX
 0167:0070000B PUSH DWORD PTR [EAX]
 0167:0070000D RET
 

Делаем u 00700005 и видим:


 0167:00700005 MOV EAX,00700690
 0167:0070000A INC EAX
 0167:0070000B PUSH DWORD PTR [EAX]
 0167:0070000D RET
 

теперь делаем d 00700690+1 (+1 тошо inc eax). Видим:


 0167:00700691 D1 AB F8 BF A3 B9 F7 BF-7E B9 F7 BF 9F 42 F8 BF ........~....B..
 0167:007006A1 B9 41 F8 BF E7 FF F7 BF-D4 49 F7 BF B8 48 F7 BF .A.......I...H..
 0167:007006B1 D7 13 F8 BF 65 43 F7 BF-3C 43 F7 BF 1A 06 FA BF ....eC..
 

Это кусок импорта! Теперь делаем хитрую вещь... /dump 700691 a4 c:\1.dmp и /load 45b140 a4 c:\1.dmp Я подменил кусок таблицы импорта на реальные адреса апи функций. Прога на этот момент запущена. И прекрасно работает ничего не заметив. Так мы поборем полиморфные вызовы. Остаются вызовы которые ведут в никуда. В никуда они вести не могут. Поэтому нужно просто глянуть на эти места когда EIP=OEP :) И действительно! В момент когда прога тока собирается запустится, все наместе и можно дописать оставшиеся куски. Там тоже будут полиморфы. Еще останется несколько вызовов процедур типа:


 0167:00700338 MOV EAX,0046C48D
 0167:0070033D NOP
 0167:0070033E PUSH DWORD PTR [EAX]
 0167:00700340 RET
 

Причем по адресу 46C48D или ноль идет или пустота... Поэтому ячейки которые указывают на такие процедуры нужно просто отсекать (cut thunks).

Итак нужно просто остановить прогу на OEP скопировать правильные адреса в таблицу импорта, а потом дать проге запуститься и дальше уже в Imprec завершить "косметику" :)




Новогодний трейсер

Автор: Hex

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

Чо такое трейсер - прога, которая пошагово выполняет код. Какие перспективы не правда ли? Делаем на основе трейсера загрузчик и прям сказка - можно запросто ломать проги, которые проверяют целостность своих данных - например дойдем до места где jnz не надо выполнять и просто переместим EIP на следующую команду (типа не выполнилось), и все красиво. Целостность не нарушена :)

Итак, как же его писать... Для того чтобы сделать трейсер нам нужны будут Debug API. Вот я тут трейсер написал чтобы находить OEP. Значит ща код трейсера для поиска Entry Point в Notepad, а потом пояснения. КОД:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Button1: TButton;
     Memo1: TMemo;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   sti: tstartupinfo;
   lpPi: tprocessinformation;
   DE: _Debug_event;
   Cont: _Context;
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 
 begin
   CreateProcess(nil, 'c:\w\notepad.exe', nil, nil, false, DEBUG_PROCESS
     or DEBUG_ONLY_THIS_PROCESS, nil, nil, StI, lpPI);
 
   while true do
   begin
     WaitForDebugEvent(de, INFINITE);
     application.ProcessMessages;
     if de.dwDebugEventCode = EXCEPTION_DEBUG_EVENT then
       if DE.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_BREAKPOINT then
       begin
         cont.ContextFlags := CONTEXT_CONTROL;
         GetThreadContext(lppi.hThread, cont);
         cont.EFlags := cont.EFlags or $100;
         setThreadContext(lppi.hThread, cont);
         ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
       end
       else if DE.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_SINGLE_STEP
         then
       begin
         GetThreadContext(lppi.hThread, cont);
         cont.EFlags := cont.EFlags or $100;
         setThreadContext(lppi.hThread, cont);
         if (cont.eip > $400000) and (cont.eip < $600000) then
         begin
           Showmessage('OEP=' + inttohex(cont.eip, 8));
           halt;
         end;
         ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
       end;
 
     ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
   end;
 
 end;
 
 end.
 

Оно работает так: Создается процесс с параметрами DEBUG_PROCESS и DEBUG_ONLY_THIS_PROCESS. DEBUG_ONLY_THIS_PROCESS - нужно для того чтобы перехватывать сообщения только от процесса, который создадим, а не все подряд. После этого создастся процесс который будет отсылать дебаговые сообщения. Делаем бесконечный цикл с WaitForDebugEvent, чтобы отлавливать дебаговые сообщения которые будет отсылать процесс. В этом цикле нам нужно будет обработать событие EXCEPTION_DEBUG_EVENT. Для этого события нам нужно будет обрабатывать 2 Exception кода: EXCEPTION_BREAKPOINT и EXCEPTION_SINGLE_STEP. Код остановки и код одиночного шага(выполнение одной команды). Когда процесс создан для дебага нам нужно будет включить флаг трассировки чтобы программа генерила EXCEPTION_BREAKPOINT и EXCEPTION_SINGLE_STEP после каждой выполненой команды. Получить данные о состоянии регистров выполняемого процесса можно через GetThreadContext, а установить их через SetThreadContext. GetThreadContext возвращает структуру _CONTEXT которая содержит данные о всех регистрах(в ключая EIP) и флагах выполняемого процесса. Но перед тем как читать данные о регистрах в эту структуру, нужно задать свойство ContextFlags=CONTEXT_CONTROL. Иначе будут возвращатся тока ноли. При обработке кодов EXCEPTION_BREAKPOINT и EXCEPTION_SINGLE_STEP нужно постоянно включать флаг трассировки через свойство EFlags структуры _CONTEXT (cont.EFlags:=cont.EFlags or $100;) После обработки каждого сообщения нужно разрешить программе выполняться дальше. Делается это через ContinueDebugEvent. Ну и наконец в обработке EXCEPTION_SINGLE_STEP я читаю текущий eip процесса, чтобы найти EP. Так как в реале, процесс начинает выполнятся не с Entry point а с загрузки всяких DLL и т.д.

Можно конечно было взять его из PE заголовка. Но это жеж не прикольно :)




Новогодний трейсер часть 2. Брейкпоинты.

Автор: Hex

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

Трассировать мы уже можем. Терь нам бы брейкпоинтов понаставить... Как ставятся брейкпоинты в обычных (не в айсе) дебагерах? Да очень просто! Вот к примеру решили мы поставить bpx на 401000h. Дебагер подрубается к процессу или запускает процесс для дебага. Потом читает байт по адресу 401000h, запоминает его и записывает на его место число CCh. А CCh - это в свою очередь опкод команды int 3h. Т.е. Debug Break. Как тока программа выполнит этот int 3h, будет сгенерено событие EXCEPTION_DEBUG_EVENT с кодом EXCEPTION_BREAKPOINT. В этот момент дебагер ставит байт по адресу 401000h на место и смещает eip на 1 назад (int 3 оно уже выполнило). Таким образом, скока брейк поинтов - стока и байт нужно будет запомнить. И так теперь можно сделать из нашего трейсера чо-нить типа SoftIce Symbol Loader. Т.е прога, которая открывает в дебагере нужный exe с адреса = Entry point ( тот что указан в PE заголовке). Собственно код:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Button1: TButton;
     Memo1: TMemo;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   sti: tstartupinfo;
   lpPi: tprocessinformation;
   DE: _Debug_event;
   Cont: _Context;
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   b: array[0..1] of byte = (0, $CC);
 var
   f: file of longint;
   x: longint;
   i: cardinal;
 begin
 
   assignfile(f, 'C:\w\notepad.exe');
   reset(f);
   seek(f, $2A); //читаем OEP из PE
   read(f, x);
   closefile(f);
   x := x + $400000; //типа imagebase
 
   //добавим еще Create_suspended чтобы процесс без нас никуда не убежал :)
   CreateProcess(nil, 'C:\w\notepad.exe', nil, nil, false, DEBUG_PROCESS
     or DEBUG_ONLY_THIS_PROCESS or Create_suspended, nil, nil, StI, lpPI);
 
   readprocessmemory(lppi.hProcess, pointer(x), @b[0], 1, i); //запоминаем байт
   writeprocessmemory(lppi.hProcess, pointer(x), @b[1], 1, i); //пишем $cc
   resumethread(lppi.hThread);
 
   {цикл ожидания EP}
   while true do
   begin
     if not WaitForDebugEvent(de, 0) then
       application.ProcessMessages;
     if de.dwDebugEventCode = EXCEPTION_DEBUG_EVENT then
       if DE.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_BREAKPOINT then
       begin
         cont.ContextFlags := CONTEXT_CONTROL;
         GetThreadContext(lppi.hThread, cont);
         {Эти брейкпоинты не тока мы генерим, но и маздай так что
         приходится проверку делать: EIP=Entry Point или нет}
 
         if cont.eip - 1 = x then
           // тошо EXCEPTION_BREAKPOINT генерится после int 3.
         begin
           cont.eip := cont.eip - 1;
           cont.EFlags := cont.EFlags or $100; //флаг T
           setThreadContext(lppi.hThread, cont);
           //ставим байт на место
           writeprocessmemory(lppi.hProcess, pointer(x), @b[0], 1, i);
           break;
         end;
         ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
       end;
     ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
   end;
 
   {tracing... 0% complete}
   while true do
   begin
 
     if not WaitForDebugEvent(de, 0) then
       application.ProcessMessages;
 
     if de.dwDebugEventCode = EXCEPTION_DEBUG_EVENT then
       if DE.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_BREAKPOINT then
       begin
         GetThreadContext(lppi.hThread, cont);
         cont.EFlags := cont.EFlags or $100;
         setThreadContext(lppi.hThread, cont);
         {Здесь мог бы быть ваш код :))) }
         ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
       end
       else if DE.Exception.ExceptionRecord.ExceptionCode = EXCEPTION_SINGLE_STEP
         then
       begin
         cont.ContextFlags := CONTEXT_CONTROL;
         GetThreadContext(lppi.hThread, cont);
         cont.EFlags := cont.EFlags or $100;
         setThreadContext(lppi.hThread, cont);
         {Здесь мог бы быть ваш код :))) }
         ContinueDebugEvent(lppi.dwProcessId, lppi.dwThreadid, DBG_CONTINUE);
       end;
   end;
 end;
 
 end.
 

P.S. Я тут Reset и Read юзал для работы с файлом. Но лучше все сделать через апи (createfile, readfile и т.д.), потому что если будет запущена прога которую мы вот ща типа трейсить будем, то делфи будет орать про I/O error. Естественно, тошо делфа не умеет открывать файл для Shared доступа :(




Visual Day Planner 7.2 - Взлом без Soft-Ice или чудовищный идиотизм

Автор: Fess

Юниксов развелось - виндовсу упасть негде...

Target: Visual Day Planner 7.2

Tools:

  • Very low brains
  • Win32Dasm 8.93

Пролог

Вступление:

Опять было нечего делать. Решил я поковырять какую-нибудь, взял диск с шароварой (журнал Hard&Soft) и наткнулся на эту программу, меня в ней привлекло то, что она была еще не сломана и имела большой размер, значит хорошо защищена подумал я.

Что за прога:

Какой-то органайзер, такими программами не пользуюсь, поэтому ничего сказать не могу. В архиве занимала 4,5 Метра (где-то, я его удалил).

Примечание:

Статья, ввиду элементарности взлома, получилась очень короткой.

Вступление

Установили. Запустили. Увидели, что вроде как триал 30 дэй. Попробо- вали зарегится, не вышло. Засунули в Дасм.

Взлом

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

Итак дизассемблировали. Идем в секцию строк и ищем, там что-то типа Wrong registration key. По ходу дела отмечаем в секции, какие-то интер- есные строки, типа: 7TY8-94734, 88J6KT9W- и др.

Меня стразу заинтересовали эти строки. Я нажал на одну из них и вы- летел в такой фрагмент:


 * Possible StringData Ref from Code Obj ->"88J6KT9W-"
                                   |
 :0050E07C 68A0264200              push 004226A0
 
 * Possible StringData Ref from Code Obj ->"3TK4-98G3G"
                                   |
 :0050E081 68D4264200              push 004226D4
 :0050E086 FFD3                    call ebx
 :0050E088 8BD0                    mov edx, eax
 ....
 :0050E0A7 FFD6                    call esi
 :0050E0A9 50                      push eax
 
 * Reference To: MSVBVM60.__vbaStrCmp, Ord:0000h <-Функция сравнения строк
                                   |
 :0050E0AA FF153C114000            Call dword ptr [0040113C]
 

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

Пароль, значит такой: "88J6KT9W-" - Первая половина, "3TK4-98G3G" - Вторая половина. Соединяем и получаем "88J6KT9W-3TK4-98G3G". Что-то по- лучилось. Будем надеяться, что это не подлянка и попробуем ввести. Вводим любое имя и компанию и этот пароль. И... Сработало. М-да, я бы таких программеров гнал из компании в зашей. Такое фуфло я видел, только один раз в программе Gif Master 1.2, а сломал я прог немало. Теперь, если хотите можете вычленить все коды.

Послесловие

Кстати, Вы за несколько минут обогатились на 29.95$, если вам удаст- ся загнать эти коды, хотя бы за половину этой суммы, то не забудьте выс- лать мне немножко.

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

Разработчики, никогда, запомните никогда не делайте такого, а то Вас просто поднимут на смех. Если прога будет так защищена. Вы не получите ни копейки.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Время работы не ограничено - Wallpaper Calendar 2.0.3

Автор: Fess

Bugs, life - программистские хроники.

Target: Wallpaper Calendar 2.0.3

Tools:

  • Some brains
  • Win32Dasm 8.93
  • Hex&Asm редактор (я использовал QView)

Все, кроме мозгов, можно найти на www.exetools.com

Вступление

Как это начиналось:

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

Что за прога:

Какой-то календарь на рабочем столе. Честно говоря говно какое-то, мне такой даром не нужен, но для взлома сойдет. В архиве эта прога занимает 1,470,ххх и написана она на Delphi. Системные требования минимальные. Имеет ограничение в свободном использовании 30 дней и я попытаюсь этот недостаток исправить.

Начало

Достали из кобуры известный всем Win32Dasm и кинули в него прогу? Она распаковалась хорошо и мы понимаем, что она ничем не запакована.

Далее заходим в секцию строк и ищем, что-нибудь про evaluation или expired, в самом начале нашлась такая строка [FREE Evaluation period over], означающая, что типа все - приехали. Посмотрим что за код скрывается рядом, щелкаем два раза и видим...


 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:004BA885(C)
 |
 * Possible StringData Ref from Code Obj ->"Wallpaper Calendar "
                            |
 :004BA8CA 6808AE4B00   push 004BAE08
 :004BA8CF 8D458C       lea eax, dword ptr [ebp-74]
 :004BA8D2 E8A1DDFFFF   call 004B8678
 :004BA8D7 FF758C       push [ebp-74]
 
 * Possible StringData Ref from Code Obj ->" [FREE Evaluation period over]"
                           |
 :004BA8DA 6854AE4B00   push 004BAE54
 

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


 :004BA86F DB6DA0         fld tbyte ptr [ebp-60]
 :004BA872 DEE1           fsubrp st(1), st(0)
 :004BA874 E83B83F4FF     call 00402BB4
 :004BA879 A32C7C4C00     mov dword ptr [004C7C2C], eax
 :004BA87E 833D2C7C4C0000 cmp dword ptr [004C7C2C], 00000000
 :004BA885 7C43           jl 004BA8CA
 

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

Как это сделать? Все до невозможного просто, если вы уже сами догадались, то делайте сами - "Практика это лучший учитель". Для тех, кто продолжает читать скажу, что здесь всего-то надо сделать ret из процедуры, до процедуры eax всегда больше 0. Как догадался? на практике проверил, вообщем, делаем так: списываем строку кода, чтобы по ней можно было найти в файле нужное место, я взял E83B83F4FF. Теперь заходим в hex&asm редактор, переходим в 32-битный режим ассемблера. И начинаем искать эту строку в QViewе надо нажать F7 и ввести эту строку. И Enter.

Так строка нашлась на 0B9C74, хорошо в путных редакторах рядом с процедурой должна быть написана цифра. Держите Shift и нажмите эту цифру и вы перенесетесь в место с процедурой. Если у вас нету цифры рядом жмите F5 и набираете 1FB4 именно по такому адресу, находится нужная процедура. Теперь можете написать C3 или перейти в режим аsm-редактирования и ввести ret, это одно и тоже. Теперь сохраняйте изменения и запускайте программу. В верхней строке написано сколько вам ее пользовать у меня это число выходило за рамки 100000. И оно не будет убавляться, так что дерзайте и все будет круто.

Послесловие

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

Господа Авторы: защита фигня, если хотите, чтобы за прогу платили баблосы - делайте защиту лучше.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Кейген для Wave Flow 4.1

Автор: Fess

Забрел как-то компьютерный вирус на зеркальный винчестер, посмотрел на свое отражение и с грустью сказал: "Сон разума рождает уродов."

Target: Wave Flow 4.1

Tools:

  • Some brains
  • TRW2000/Soft-Ice
  • Win32Dasm 8.93
  • Pascal

Все, кроме мозгов, можно найти на www.exetools.com

Вступление

Как это начиналось:

Был обычный серый вечер, на часы в гостинной показывали 21:40. До фильма оставался ровно час и я решил заняться делом: что-нибудь поломать. Первым попавшимся под руку диском с шароварой оказался Hard&Soft 9.2001. На нем я обнаружил несколько не ломанных мной ранее программ. Среди них была и Wave Flow 4.1. Установил все как обычно.

Что за прога:

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

Начало

Что же мы будем сегодня делать? А сделаем мы два кейгена: один на основе самой проги, второй на Паскале (Вы его не знаете? Тогда учите быстрей)

Проги на Дельфях проще ломать с помощью SoftIce, то мы и делаем. Запускаем прогу, нажимаем на кнопочки Register и Enter Passowrd. Вводим любое имя и код, код лучше взять такой, чтобы точно не встречался в памяти, я беру всегда такой 110022334455. Ну, а имя Fess. Нажимаем Ctrl+Dи вываливаемся в айсе, пишем команду s 0 l -1 "110022334455". Команда означает, что нужно искать строку "1100.." во всей памяти. Она как ни странно нашлась :). Адрес памяти должен начинаться с 8. Ставим бряк на этот адрес командой bpmb адрес rw. Где вместо адрес вписываем ваш адрес. Вводим. Выходим из айса по кнопке F5 или Ctrl+D. Нажимаем Ok и вываливаемся в айсе. Раз восемь делаем F12, пока не дойдем до такого блока команд.


 :00472451 8B45F0       mov eax, dword ptr [ebp-10]
 :00472454 50           push eax
 :00472455 8D55EC       lea edx, dword ptr [ebp-14]
 :00472458 8B45FC       mov eax, dword ptr [ebp-04]
 :0047245B 8B80D4020000 mov eax, dword ptr [eax+000002D4]
 :00472461 E886E5FBFF   call 004309EC
 :00472466 8B45EC       mov eax, dword ptr [ebp-14]
 :00472469 8D55F4       lea edx, dword ptr [ebp-0C]
 :0047246C E8E3040000   call 00472954
 :00472471 8B55F4       mov edx, dword ptr [ebp-0C]
 :00472474 58           pop eax
 :00472475 E8D21AF9FF   call 00403F4C
 :0047247A 0F85C8010000 jne 00472648
 

Проходим первую строку, набираем команду d eax. И мы видим введенный код. Идем дальше по F10, проверяя изменяющиеся адреса. По адресу указанному в edx, после прохода выделенной строки мы видим, какую-то строку цыфирек. Это наводит на мысль о том, что это настоящий код. Так и есть, если вам просто нужно сломать, то можете паковать вещи, а я продолжу. Код мы узнали, но как быть, если у Вас сотня друзей, у которых еще по сотне и все хотят зарегить прогу на свое имя. Можно, конечно, поставить бряк на эту строку и каждому выдавать код. А можете сбатцать кейген и давать его всем и пусть нагенерят себе кодов сколько надо. И Вы сможете потратить свое время более логично.

Скорее всего код генерится в процедуре по адресу 47246C. Потому что, если посмотреть на две строчки перед ней, то ясно видно как ей передается в eax наше введенное имя. Значит смотрим в процедуру и пытаемся разобраться в ее назначении. Я, конечно, прокомментирую этот код, но вы попробуйте сами разобраться в его назначении в отладчике.


 :00472954 55          push ebp
 (...выброшена часть ненужно кода)
 :00472981 8B45FC      mov eax, dword ptr [ebp-04] < Адрес на имя
 :00472984 E8B314F9FF  call 00403E3C  < Проверка длинны имени, результат в eax
 :00472989 85C0        test eax, eax  < Проверка длинны
 :0047298B 7E13        jle 004729A0   < Если длинна = 0, то гуляй Вася
 :0047298D BA01000000  mov edx, 00000001  < Счетчик на 1
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0047299E(C)
 |
 :00472992 8B4DFC     mov ecx, dword ptr [ebp-04]  < Берем адрес на введенное имя
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0047291F(C)
 |
 :00472995 0FB64C11FF movzx ecx, byte ptr [ecx+edx-01] < Берем символ имени в зависимости от счетчика
 :0047299A 03D9       add ebx, ecx                     < Добавляем к сумме (ebx) код символа
                                                       \ В начале ebx=0
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0047292E(C)
 |
 :0047299C 42         inc edx   < Увеличиваем счетчик
 :0047299D 48         dec eax   < Убавляем от длинны имени один
 :0047299E 75F2       jne 00472992 < Пока в eax не ноль переход работает
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0047298B(C)
 |
 :004729A0 895DF8     mov dword ptr [ebp-08], ebx   < Сохраняем сумму
 

Далее идут команды сопроцессора (префикс f). Для их понимания желательно иметь книжку с описание команд процессора, у меня это В. Юров "Ассемблер. Специальный справочник". В принципе это можно достать с сайта интела www.intel.com, но там на англицком, а мене русский ближе. Я в кратце объясню, что делает блок кода до 4729B3. Берем сумму из кодов символов имени и умножаем это на 0.8 результат в eax. Честно признаюсь, что в начале забыл про книжку и нашел это опытным путем (методом профессионального тыка).


 :004729A3 DB45F8     fild dword ptr [ebp-08] < Преобразование операнда в целочисленном формате
                                               \ в вещественный
 :004729A6 DB2DF8294700 fld tbyte ptr [004729F8] < Загрузка в стек вещественного значения (0.8)
 :004729AC DEC9       fmulp st(1), st(0)  < Умножаем сумму на 0.8, результат в стеке
 :004729AE E87100F9FF call 00402A24
   [начало процедуры
   [:00402A24 83EC08  sub esp, 00000008
   [:00402A27 DF3C24  fistp qword ptr [esp] < Результат в вершину стека
   [:00402A2A 9B      wait
   [:00402A2B 58      pop eax < Берем результат из стека в eax
   [:00402A2C 5A      pop edx
   [:00402A2D C3      ret
   [конец процедуры
 :004729B3 F7E8       imul eax  < Умножаем eax на eax, т.е. возводим eax во вторую степень
 :004729B5 8BF8       mov edi, eax  < Переносим eax в edi
 :004729B7 8B45FC     mov eax, dword ptr [ebp-04] < В eax адрес памяти указывающий на имя
 :004729BA E87D14F9FF call 00403E3C < В eax возвращается длинна имени
 :004729BF 03C0       add eax, eax  < eax=eax+eax или eax=eax*2
 :004729C1 03D8       add ebx, eax  < Прибавляем к сумме длинну умноженную на 2
 :004729C3 8BC3       mov eax, ebx  < eax=ebx
 :004729C5 03C0       add eax, eax  < eax=eax+eax
 :004729C7 03F8       add edi, eax  < Прибавляем ко всему этому (eax)
                                    \сумму умноженную на 0.8 во второй степени (edi)
 :004729C9 8BC7       mov eax, edi  < eax=edi
 :004729CB 8BD6       mov edx, esi  < В edx адрес памяти куда запишется правильный код
 :004729CD E8EE5AF9FF call 004084C0 < Преобразуем полученное (eax) в строку десятичных символов,
                                    \ которая является правильным кодом
 

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


 PROGRAM KeyGen;{Keygen for WaveFlow 4.1}
 Uses Crt; {Заявляем об использовании модуля Crt}
 Var        {Блок объявления переменных}
  S:String;
  N:LongInt;
  B:Byte;
 Begin      {Начало программы}
   ClrScr;  {Очищаем экран}
   WriteLn('KeyGen For WaveFlow 4.1 by Fess [PTDS] URL: vallkor.chat.ru');
      {Выводим строку, типа сбацал я}
   WriteLn; {Пропускаем строку}
   Write('Enter name: '); {Просим ввести имя}
   ReadLn(S);  {Берем имя в переменную S}
   N:=0; {Присваиваем сумме начальное значение 0}
   For B:=1 to Length(S) Do N:=N+Ord(S[B]); {Считаем сумму кодов имени}
   N:=SQR(Round(N*0.8) {Сумму умножаем на 0.8 и возводим во вторую степень}
      + (N + Length(S)*2)*2 ); {Прибавляем к сумме длинну умноженную на 2 и все это умножаем на 2}
   Write('Your Key: ',N); {Выводим получившийся код}
   If readkey=#0 then;   {Ждем нажатия на любую клавишу}
 End.       {Конец программы}

Процедура генерации опробована и проверена!! Так что ошибок нет. Сделана на Turbo Pascal 7.0.

Для имени FessCool код должен быть 408672.

Будем надеятся, что вы все поняли из выше сказанного, если что-то непонятно пишите на мыло. Я помогу!

Послесловие

Спасибо автору за предоставленный для исследования продукт. Было очень интересно. Спасибо фирме Borland за превосходный Паскаль, без которого я жить не могу. :)

Господа Авторы: Ну, как это назвать?!! Очень стандартная защита, короче мусор. Нормальный крэкер сломает ее на несколько минут. Хотите получать деньги делайте защиту лучше! 25 US$ баксов для России это очень много, а крэкеров в России много! Россия рулез!

Братья Крэкеры: Не стоит сильно ругать авторов, они там за бугром не ведают, что творят.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Кейген для WinMusic JukeBox 4.0

Автор: Fess

Почемy ломание программ лучше секса.
1. Ломать программы можно более 6 часов непрерывно.
2. У программ не бывает периодов, когда их нельзя ломать.
3. Тебе не надо всякий раз покупать новый отладчик и дизассемблер чтобы сломать очередную программу.
4. Когда ты ломаешь программу она y тебя не спрашивает, сколько программ ты сломал до нее и во сколько лет сломал первую программу.
5. Можно ломать две, три и более программы одновременно.
6. Одновременно с ломанием программы можно кушать, смотреть телевизор и читать книжку.
7. Чем быстрее ты сломаешь программу, тем лучше.
8. Программа никогда не скажет "А прошлый кpакеp меня дольше ломал."
9. Ломать программы можно в присутствии друзей, родителей и преподавателей.
10. Когда ты сломал программу, то можешь (и хочешь) приступить к слому другой уже через пару минут.
11. После того как ты сломал программу y тебя не болит спина и не заплетаются ноги.
12. Одну программу достаточно сломать один раз.
13. Тебя не заставляют жениться на сломанной программе.
14. Кpак к программе можно подарить своим друзьям или продать.
15. Если тебе вдруг надоело, то ты можешь остановиться и продолжить ломать программу на следующей неделе.

Target: WinMusic Jukebox 4.0

Tools:

  • Some brains
  • TRW2000/Soft-Ice
  • Win32Dasm 8.93
  • Delphi

Вступление

Как это начиналось:

После недолгого перерыва, сейчас посмотрю сколько прошло... Кто-нибудь мне подскажет сколько будет 23-7, а? Нет не 1С, не в шестнадцатеричном формате живем, а прошло 16 дней. Нифига себе сказал я и решил порадовать Вас новым тьюториалом. Что ж читайте и путь с вами пребудет великий дух bad-сектора.

Что за прога:

Да, кто его знает. шваль какая-то за 19 убитых енотов, но у нас на такое г**** денег нет, так что будем ломать и не просто, а срубим настоящий кейген. Прога для работы с музыкой или что-то в этом роде, в архиве 793 кило, так что качайте и приступим.

Начало

Так, так, так, что это за зверь?

Попробуем понять запакована ли программа, а поскольку мы не долбаные ламеры, определим это в ручник. Запускаем любой просмотрщик ресурсов (Я пользуюсь встроенным в WinNavigator. И вообще это прога must have и рулез форева). Так секция строк просматривается нормально, значит прога не пакована. Попробуем кинуть его в Win32Dasm.

Вроде, все прошло нормально, но что-то недает нам покоя, а это то, что это прога 16-битное приложение, а не 32-х. Но мы кул хацкеры и поламаем и такую гадость. Верно ведь?

Пожалй пришло время запустить саму прогу и посмотреть ее реакцию на любой пароль, там вывалилась в MessageBoxe, такая строка Invalid Registration Information. Да как эта недостойная прога посмела отказать нам в регистрации, но мы добьемся своего любой ценой. Ищем эту строку в секции строк Win32Dasmа, когда найдем жмем два раза и оказываемся здесь.


 :0001.0487 50           push ax
 :0001.0488 56           push si
 :0001.0489 9A6210FFFF  call 0001.1062
 :0001.048E 83C406       add sp, 0006
 :0001.0491 0BC0         or ax, ax
 :0001.0493 7419         je 04AE
 :0001.0495 C7065A680100 mov word ptr [685A], 0001
 :0001.049B 56           push si
 :0001.049C 1E           push ds
 
 * Possible StringData Ref from Data Seg 004 ->"Thank you for your Registration."
                                   |
 :0001.049D 68AF00       push 00AF
 :0001.04A0 1E           push ds
 
 * Possible StringData Ref from Data Seg 004 ->"WINMUSIC JUKEBOX"
                                   |
 :0001.04A1 689E00       push 009E
 
 * Possible StringData Ref from Data Seg 004 ->"Registered to: "
                                   |
 :0001.04A4 6A30         push 0030
 :0001.04A6 9ABA040000   call USER.MESSAGEBOX
 :0001.04AB 56           push si
 :0001.04AC EB15         jmp 04C3
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0001.0493(C)
 |
 :0001.04AE 56           push si
 :0001.04AF 1E           push ds
 
 * Possible StringData Ref from Data Seg 004 ->"Invalid Registration Information."
                                   |
 :0001.04B0 68E100       push 00E1
 :0001.04B3 1E           push ds
 
 * Possible StringData Ref from Data Seg 004 ->"WINMUSIC JUKEBOX"
                                   |
 :0001.04B4 68D000       push 00D0
 

Все как обычно, простой переход, если неправильный ключ. Посмотрим чуть повыше перехода и видим строку or ax, ax, что это такое думаете вы, да все просто это почти тоже самое, что и test eax,eax, к которому мы привыкли. Соответственно если выделенная процедура возвращает 0, то переходим на неправильно, если не равно 0, то все в порядке. Здесь очень легко можно сделать патч, это удалить переход, и более верное сделать так, чтобы процедура всегда возвращала число не равное 0. Как это сделать было подробно описано в других моих тьюториалах. Сегодня я хочу сделать кейген.

Смотрим еще чуть выше. Тут вызывается два раза процедура GETDLGITEMTEXT, (! НЕ ПУТАЙТЕ С GetDlgItemTextA это разные вещи). А значит пришло время отладчика, я пользую TRW2000, т.к. перезагружаться в падлу мне всегда.

Ставим бряк на эту процедуру bpx GETDLGITEMTEXT. И запускаем прогу и вводим любое имя и любой код (я ввел Fess и 110022334455), один раз пропускаем, нажимаем F12 и оказываемся, где нужно. (В TRW2000 надо еще 1 раз нажать F8). Т.е. на строке 0001.0480. Идем до нужной на процедуры и заходим в нее.

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


 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0001.10D5(C)
 |
 :0001.10D9 56        push si
 :0001.10DA 9A483F0A11 call 0003.3F48
 :0001.10DF 5B        pop bx
 :0001.10E0 8946FC    mov [bp-04], ax
 :0001.10E3 8B4608    mov ax, [bp+08]
 :0001.10E6 8946FE    mov [bp-02], ax
 :0001.10E9 8BF0      mov si, ax
 

Процедура вызывает у нас подозрение, встав на строке 10D9 или на самой процедуре, пишем команду d si (Не esi, только si). Но в окне кода мы не видим ничего путного, потом до нас доходит, что прога 16-битная, а значит надо писать d ds:si и мы видем первые 5 символов нашего введенного кода. Так же вызывает подозрение строка 10E0 тут возвращенное процедурой значение пихают в память (в переменную). Я решил зайти и проверить, что это за процедура, а вы со мной, так как иначе нельзя! Я не буду рассматривать всю процедуру, там в начале обнуление, а потом, проверка на вхождение кода в рамки от 0 до 9, короче идем до след. участка кода.


 В начале bx и dx равны 0.
 :0003.3F6F AC                     lodsb <-берем символ 1 кода в ax
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0003.3F6D(C)
 |
 :0003.3F70 3C39    cmp al, 39 <- если больше, т.е. больше '9'
 :0003.3F72 771F    ja 3F93
 :0003.3F74 2C30    sub al, 30 <- вычитаем их al 30
 :0003.3F76 721B    jb 3F93
 :0003.3F78 D1E3    shl bx, 01 <- Далее куча сдвигов хитрожопых
 :0003.3F7A D1D2    rcl dx, 01
 :0003.3F7C 8BCB    mov cx, bx
 :0003.3F7E 8BFA    mov di, dx
 :0003.3F80 D1E3    shl bx, 01
 :0003.3F82 D1D2    rcl dx, 01
 :0003.3F84 D1E3    shl bx, 01
 :0003.3F86 D1D2    rcl dx, 01
 :0003.3F88 03D9    add bx, cx
 :0003.3F8A 13D7    adc dx, di
 :0003.3F8C 03D8    add bx, ax   <- bx=bx+ax
 :0003.3F8E 83D200  adc dx, 0000
 :0003.3F91 EBDC    jmp 3F6F <- снова
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:0003.3F72(C), :0003.3F76(C)
 
 |:0003.3F93 58     pop ax
 :0003.3F94 3C2D    cmp al, 2D     <- если последний символ '-' то не переходит
 									 (У нас в коде таких не будет можете забыть)
 :0003.3F96 93      xchg ax,bx     <- ax = bx
 :0003.3F97 7507    jne 3FA0       <- если не равно переход (точно не равно переходим)
 :0003.3F99 F7D8    neg ax
 

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


 :0001.10F0 8A04        mov al , [si]  <- берем символ имени в al
 :0001.10F2 257F00      and ax, 007F   <- присваиваем ah=0
 :0001.10F5 8BC8        mov cx, ax     <- cx=ax
 :0001.10F7 8D5BC8      lea bx, [bp+di-38]  <- bx=bp+di-38
 :0001.10FA 368B01      mov ax, ss:[bx+di]  <- берем в ax символ по адресу ss:[bx+di]
 :0001.10FD F7E9        imul cx             <- ax=ax*cx
 :0001.10FF 0146FA      add [bp-06], ax     <- добавляем в переменную еще 1 значение
 										    (в первый раз переменная равна 0)
 :0001.1102 47          inc di              <- увеличиваем счетчики
 :0001.1103 46          inc si              <- увеличиваем счетчики
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0001.10EE(U)
 |
 :0001.1104 FF7608      push word ptr [bp+08]
 :0001.1107 9ACA3EC40C  call 0003.3ECA <- возвращает длинну имени
 :0001.110C 5B          pop bx
 :0001.110D 034608      add ax, [bp+08]
 :0001.1110 3BC6        cmp ax, si
 :0001.1112 77DC        ja 10F0 <- не помню, пока символы имени не кончатся повторяем
 :0001.1114 8B56FA      mov dx, [bp-06] <- берем все суммы в dx
 :0001.1117 B81879      mov ax, 7918    <- ax=7918h
 :0001.111A 2BC2        sub ax, dx      <- ax=ax-dx
 :0001.111C 8BD0        mov dx, ax      <- dx=ax
 :0001.111E 3B56FC      cmp dx, [bp-04] <- сравниваем если равны, то зарегена
 :0001.1121 752F        jne 1152
 

Рекомендую повнимательней приглядеться к строке 10FA, там поочереди берутся значения 3 8 3 3 5 2 3 5 3 2 7 5 6 4 3 7 7 6 7 5 и заносятся в ax. Это к сведению.

В принципе теперь все понятно. Здесь можно обойтись простым перебором всех кодов, я не проверял является ли обратимой функция вычисления по коду, но врядли. Короче, перебор все номеров от 10000 до 99999.

Вот я сляпал кейген на Делфи, разбирайтесь. Как всегда затащите на форму два компонетна Edit (по умолчанию их имена Edit1 и Edit2) и одну кнопку, нажмите на кнопку два раза и вставьте нижеследующий код. Потом запустите программу в Edit1 введите свое имя и нажмите на кнопку и в Edit2 появиться настоящий код.


 procedure TForm1.Button1Click(Sender: TObject);
 Var
  S:String;
  DXX,BXX,Itog, Cod:Word;
  EDXX,Z:Dword;
  I:Byte;
  Ura:Boolean;
 begin
   S:='38335235327564327675'; //  Это числа я Вам писал
   Itog:=0; //Общая пин-ключ для имени
   For I:=1 To Length(Edit1.Text) Do // Процедура генерации пинключа для имени
   Begin
     EDXX:=Ord(S[I])-$30;
     DXX:=Ord(Edit1.Text[I]);
     asm
      mov eax,edxx
      mov cx,DXX
      imul cx
      add itog,ax
     end;
   End;
   Itog:=$07918-Itog; //Пин-ключ для имени готов, теперь приступаем к подбору
      //пин-ключа для кода
 
   Ura:=False; //Переменаая Ura будет True когда два пин-ключа будут равны
   Z:=10000; // Код с которого начинаем подбор
   repeat    //Цикл перебора возможных кодов
    BXX:=0;
    DXX:=0;
    S:=IntToStr(Z);
 
   For I:=1 To 5 Do  //Цикл для вычисления пин-ключа для кода
   Begin
     Cod:=Ord(S[I])-$30;
    asm
     pusha
     mov ax, Cod
     mov bx,BXX
     mov dx, DXX
     shl bx,1
     rcl dx,1
     mov cx, bx
     mov di,dx
     shl bx,1
     rcl dx,1
     shl bx,1
     rcl dx,1
     add bx,cx
     adc dx,di
     add bx,ax
     mov dxx,dx
     mov bxx, bx
     popa
    end;
 
   End;
 
   if bxx=itog then Ura:=True; // Сошлось УРА, то Ura:=True
   Inc(Z);
   until (Z>99999) or (Ura); // Перебор пока все коды не выйдут
 
   Edit2.Text:=S; // Подобраный код в Edit2, или если не подобрал, то 100000,
     // Но у меня такого не было, всегда был код
 end;

Процедура генерации опробована и проверена!! Так что ошибок нет. Сдалана на Delphi 4.5, я думаю, подойдут все версии, начиная с 4.

Для имени Fess код должен быть 29292.

Будем надеятся, что вы все поняли из выше сказанного, если что-то непонятно пишите на мыло. Я помогу!

Послесловие

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

Господа Авторы: защита фигня, если хотите, чтобы за прогу платили баблосы - делайте защиту лучше.

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Исследование программы Xmcoder

Автор: Gas Man

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

Для того чтоб зарегистрировать программу ее следует изучить т.е. посмотреть ее реакцию на введение s/n, unlocking code или reg.no. Сообщения к-рые выдает программа на введение неверных ключевых данных лучше запомнить или записать - они нам еще понадобятся.

Используемые инструменты: SoftICE,WDasm89

Запускаем xmencoder. Жмем кнопку Buy now.Попали в экран User Registration - заполняем все поля информацией т.к. программа очень требовательна и не допускает пустых полей ;) Ok! Заполнили. Идем дальше. Предлагают купить Item(s) - проверяем кошелек если есть лишние $89 дальше лучше не читайте, а просто заплатите и все ;) (у меня не было :(( ) Идем далее. Предлагают выбрать способ оплаты. Мне понравилась Visa (т.к. не надо лишний раз тыкать мышОй) Пишете ваш номер кредитки если есть :), если нет то попробуйте подобрать любой подходящий ежели лень, то подсказываю: 13 шестерок проходит на УРА! Далее попадаем в форму для комментариев - вот где душу можно отвести и клаву потоптать! Но помните, скорее всего никто не прочтет ваши излияния ;)) После комментариев проходим еще один экран последнего подтверждения информации и ...

Попадаем в экран выбора способа оплаты Выберите OREDER BY PHONE и дальше. Теперь спрашивают unlocking code :)) Введите любой бред. Получите сообщение типа Sorry, that unlocking code .... что-ж, не угадали :(( Теперь поищем эту строку в директории с Xing MPEG Encoder'ом Вуаля - Есть вхождение в rsagnt32.dll

Дизассемблируем его, и находим 4 ссылки на эту строку


 * Reference To: USER32.GetDlgItemTextA, Ord:00F5h
 :1000466A FF15A4850310 Call dword ptr [100385A4] ;читаем unlocking code
 :10004670 B9FFFFFFFF mov ecx, FFFFFFFF
 :10004675 2BC0 sub eax, eax
 :10004677 F2 repnz ;вычисляем длину
 :10004678 AE scasb
 :10004679 F7D1 not ecx
 :1000467B 49 dec ecx
 :1000467C 83F90A cmp ecx, 0000000A ;если не равно
 :1000467F 743E je 100046BF ;10 то выдаем
 :10004681 A164F20210 mov eax, dword ptr [1002F264] ;сообщение
 * Possible StringData Ref from Data Obj ->"Sorry, that unlocking code is "
 ->"not valid for this program."
 :10004686 6818150210 push 10021518
 

(такая же конструкция находится по адресу 10001F03; какая исполняется очевидно зависит от выбранного способа оплаты) Нам надо поменять условный переход на безусловный т.е.


 :1000467F EB3E jmp 100046BF
 

и параллельно


 :10001F25 7440 je 10001F67
 

на


 :10001F25 EB40 jmp 10001F67
 

Можно конечно и не менять а ввести любую белиберду из 10 знаков Оппа! Вторая часть полученного сообщения наводит на мысль о том, что программа защищена Release Software Agent Но первая часть осталась неизменной Sorry, that unlocking code ...

Что-ж, смотрим далее


 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:10001FCA(C)
 :10002288 A164F20210 mov eax, dword ptr [1002F264]
 * Possible StringData Ref from Data Obj ->"Sorry, that unlocking code is"
 ->"not valid for this program."
 :1000228D 6818150210 push 10021518
 

(аналогичная конструкция по адресу :1000474D).

Посмотрим на условный переход, который нас сюда приносит с адреса 10001FCA


 :10001FBA 6860FE0210 push 1002FE60 ;заносим в стек
 :10001FBF 51 push ecx ;параметры ф-ции
 :10001FC0 E89BDC0100 call 1001FC60 ;вызывается ф-ция
 :10001FC5 83C408 add esp, 00000008 ;корректируется стек
 :10001FC8 85C0 test eax, eax ;проверяется возвращаемое знач-е
 :10001FCA 0F85B8020000 jne 10002288 ;если не 0 то выдаем уже знакомое нам сообщение
 

Если посмотреть на ф-цию по адресу 1001FC60, то там можно увидеть


 :1001FC60 55 push ebp ;сохраняем индексный регистр
 :1001FC61 8BEC mov ebp, esp ;сохраняем позицию стека
 :1001FC63 57 push edi
 :1001FC64 56 push esi
 :1001FC65 53 push ebx
 :1001FC66 8B750C mov esi, dword ptr [ebp+0C] ;берем один параметр ф-ции
 :1001FC69 8B7D08 mov edi, dword ptr [ebp+08] ;берем другой параметр ф-ции
 :1001FC6C 8D05688C0210 lea eax, dword ptr [10028C68]
 :1001FC72 83780800 cmp dword ptr [eax+08], 00000000
 :1001FC76 753B jne 1001FCB3 ;по этому переходу мы тоже будем проверять строки, но немножко по-другому, очевидно, это зависит от продукта к-рый регистрируем
 :1001FC78 B0FF mov al, FF ;загружаем в eax
 :1001FC7A 8BC0 mov eax, eax ;начальные данные
 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:1001FC88(C), :1001FCA8(C)
 :1001FC7C 0AC0 or al, al ;начало цикла сравнения
 :1001FC7E 742E je 1001FCAE ;если нечего сравнивать уходим
 :1001FC80 8A06 mov al, byte ptr [esi];берем символ из одной строки
 :1001FC82 46 inc esi ;увеличиваем счетчик первой строки
 :1001FC83 8A27 mov ah, byte ptr [edi];берем символ из другой строки
 :1001FC85 47 inc edi ;увеличиваем счетчик второй строки
 :1001FC86 38C4 cmp ah, al ;сравниваем
 :1001FC88 74F2 je 1001FC7C ;если равно, то на начало цикла
 :1001FC8A 2C41 sub al, 41 ;преобразуем в нижний регистр
 :1001FC8C 3C1A cmp al, 1A ;один символ
 :1001FC8E 1AC9 sbb cl, cl
 :1001FC90 80E120 and cl, 20
 :1001FC93 02C1 add al, cl
 :1001FC95 0441 add al, 41
 :1001FC97 86E0 xchg al, ah
 :1001FC99 2C41 sub al, 41 ;а теперь другой
 :1001FC9B 3C1A cmp al, 1A
 :1001FC9D 1AC9 sbb cl, cl
 :1001FC9F 80E120 and cl, 20
 :1001FCA2 02C1 add al, cl
 :1001FCA4 0441 add al, 41
 :1001FCA6 38E0 cmp al, ah ;сравним и если равно
 :1001FCA8 74D2 je 1001FC7C ;то на начало цикла
 :1001FCAA 1AC0 sbb al, al ;если нет, то очищаем al
 :1001FCAC 1CFF sbb al, FF ;заносим в al 1
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:1001FC7E(C)
 :1001FCAE 0FBEC0 movsx eax, al
 :1001FCB1 EB6F jmp 1001FD22 ;на выход (в eax результат сравнения)
 

Нам надо, чтоб ф-ция выдавала всегда 0 в eax, для этого есть много способов, я выбрал следующий:


 :1001FCAC 33C0 xor eax, eax
 

В результате ф-ция всегда вернет нам 0 в eax - что нам и надо :))

Патчим rsagnt32.dll, запускаем xmcoder и ... получаем сообщение Application Error : Important application files are missing or corrupted :(( Значит программа вычисляет контрольную сумму rsagnt32.dll. Поищем эту строку в каталоге программы.

Нашли в xmcoder.exe Дизассемблируем его и увидим 2 обращения к этой строке в одной и той же ф-ции, вот ее текст


 :004033D0 56 push esi
 :004033D1 6A00 push 00000000
 :004033D3 6A00 push 00000000
 :004033D5 E816FAFFFF call 00402DF0
 :004033DA 83C408 add esp, 00000008
 :004033DD 83F801 cmp eax, 00000001 ;проверка значения возвращаемого
 :004033E0 7433 je 00403415 ;ф-цией если не 1 то получаем MessageBox
 :004033E2 6810200000 push 00002010
 * Reference To: USER32.MessageBoxA, Ord:0195h
 |
 :004033E7 8B3548C54200 mov esi, dword ptr [0042C548] ;заносим адрес MessageBoxA в esi и в стек параметры вызова
 * Possible StringData Ref from Data Obj ->"Application Error"
 |
 :004033ED 6884844100 push 00418484
 * Possible StringData Ref from Data Obj ->"Important application files are "
 ->"missing or corrupted."
 |
 :004033F2 6834844100 push 00418434
 :004033F7 6A00 push 00000000
 :004033F9 FFD6 call esi ;непосредственно вызов MessageBoxA
 :004033FB A100F14100 mov eax, dword ptr [0041F100]
 :00403400 50 push eax
 :00403401 E86A450000 call 00407970
 :00403406 83C404 add esp, 00000004
 :00403409 6A00 push 00000000
 :0040340B E880870000 call 0040BB90
 :00403410 83C404 add esp, 00000004
 :00403413 EB06 jmp 0040341B
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:004033E0(C)
 |
 * Reference To: USER32.MessageBoxA, Ord:0195h
 |
 :00403415 8B3548C54200 mov esi, dword ptr [0042C548] ;в esi заносим адрес MessageBoxA
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:00403413(U)
 |
 :0040341B E8B0E8FFFF call 00401CD0 ;вызов ф-ции
 :00403420 85C0 test eax, eax ;проверка возвращаемого значения
 :00403422 752B jne 0040344F ;и если eax=0 получаем MessageBox с ошибкой если eax=0 идем на ret
 :00403424 6810200000 push 00002010 ;в стек параметры вызова MessageBox'а
 * Possible StringData Ref from Data Obj ->"Application Error"
 |
 :00403429 6884844100 push 00418484
 * Possible StringData Ref from Data Obj ->"Important application files are "
 ->"missing or corrupted."
 |
 :0040342E 68E4834100 push 004183E4
 :00403433 6A00 push 00000000
 :00403435 FFD6 call esi
 :00403437 A100F14100 mov eax, dword ptr [0041F100]
 :0040343C 50 push eax
 :0040343D E82E450000 call 00407970
 :00403442 83C404 add esp, 00000004
 :00403445 6A00 push 00000000
 :00403447 E844870000 call 0040BB90
 :0040344C 83C404 add esp, 00000004
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:00403422(C)
 |
 :0040344F 33C0 xor eax, eax
 :00403451 5E pop esi
 :00403452 A3D8F24100 mov dword ptr [0041F2D8], eax
 :00403457 A3A0C94100 mov dword ptr [0041C9A0], eax
 :0040345C A3DCF24100 mov dword ptr [0041F2DC], eax
 :00403461 C3 ret
 

Изменим 2 условных перехода на безусловные и запустим xmcoder


 :004033E0 EB33 jmp 00403415
 :00403422 EB2B jmp 0040344F
 

Уверенно жмем Buy now, проходим уже знакомые экранные формы и .... получаем поздравительное рукопожатие (одна из этих рук на картинке точно моя ;)))! Поздравляю! После минутного процесса получаете полнофункциональный XING MPEG Coder. Правда я не проверял - не моя специфика, но все вроде выглядит достоверно :)) 2Release Software Agent: Фуфло гоните ребята! Хоть бы строки зашифровывали!

Подводим итоги :


 Xing MPEG Coder cracked by Gas
 rsagnt32.crk
 1325 74 EB
 3A7F 74 EB
 1F0AC 1C 33
 1F0AD FF C0
 
 xmcoder.crk
 27E0 74 EB
 2822 75 EB
 

P.S. Прошу не ругать за корявый язык написания статьи
Время crack'а=10 min
Время написания статьи = 1 hour
Видите - старался!

Примечание от Zet'а.

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




Зарисовка на тему экспорта в Excel

Рано или поздно практически каждый программист сталкивается с необходимостью организовать экспорт данных в MS Office. При этом каждое "поколение" программистов натыкается на одни и те же вилы.

Вот три часто встречающихся вопроса.

  1. Как определить установлен ли Excel
  2. Как определить запущен ли Excel
  3. Как вывести данные в Excel

Большую помощь в понимании этих и других вопросов приносит чтение исходных текстов функций модуля ComObj. :)

Во всех случаях следует подключить модули ComObj и ActiveX

1. Как определить установлен ли Excel

Функция возвращает True если найден OLE-объект

Пример использования


 if not IsOLEObjectInstalled('Excel.Application') then
   ShowMessage('Класс не зарегистрирован')
 else
   ShowMessage('Класс найден');
 
 
 function IsOLEObjectInstalled(Name: String): boolean;
 var
   ClassID: TCLSID;
   Rez : HRESULT;
 begin
   // Ищем CLSID OLE-объекта
   Rez := CLSIDFromProgID(PWideChar(WideString(Name)), ClassID);
 
   if Rez = S_OK then  // Объект найден
     Result := true
   else
     Result := false;
 end;
 
 

Если нужна более подробная информация об объекте, можно почитать хелп по функции API CLSIDFromProgID.

2. Как определить запущен ли Excel

Данный пример ищет активный экземпляр Excel и делает его видимым


 var
     ExcelApp : Variant;
 begin
   try
     // Ищем запущеный экземплят Excel, если он не найден, вызывается исключение
     ExcelApp := GetActiveOleObject('Excel.Application');
 
     // Делаем его видимым
     ExcelApp.Visible := true;
   except
   end;
 end;
 

3. Как вывести данные в Excel

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


 var
     ExcelApp, Workbook, Range, Cell1, Cell2, ArrayData  : Variant;
     TemplateFile : String;
     BeginCol, BeginRow, i, j : integer;
     RowCount, ColCount : integer;
 begin
   // Координаты левого верхнего угла области, в которую будем выводить данные
   BeginCol := 1;
   BeginRow := 5;
 
   // Размеры выводимого массива данных
   RowCount := 100;
   ColCount := 50;
 
   // Создание Excel
   ExcelApp := CreateOleObject('Excel.Application');
 
   // Отключаем реакцию Excel на события, чтобы ускорить вывод информации
   ExcelApp.Application.EnableEvents := false;
 
   //  Создаем Книгу (Workbook)
   //  Если заполняем шаблон, то Workbook := ExcelApp.WorkBooks.Add('C:\MyTemplate.xls');
   Workbook := ExcelApp.WorkBooks.Add;
 
   // Создаем Вариантный Массив, который заполним выходными данными
   ArrayData := VarArrayCreate([1, RowCount, 1, ColCount], varVariant);
 
   // Заполняем массив
   for I := 1 to RowCount do
     for J := 1 to ColCount do
       ArrayData[I, J] := J * 10 + I;
 
   // Левая верхняя ячейка области, в которую будем выводить данные
   Cell1 := WorkBook.WorkSheets[1].Cells[BeginRow, BeginCol];
   // Правая нижняя ячейка области, в которую будем выводить данные
   Cell2 := WorkBook.WorkSheets[1].Cells[BeginRow  + RowCount - 1, BeginCol +
 ColCount - 1];
 
   // Область, в которую будем выводить данные
   Range := WorkBook.WorkSheets[1].Range[Cell1, Cell2];
 
   // А вот и сам вывод данных
   // Намного быстрее поячеечного присвоения
   Range.Value := ArrayData;
 
   // Делаем Excel видимым
   ExcelApp.Visible := true;
 




Как экспортировать таблицу базы данных в ASCII-файл


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Db, DBTables, Grids, DBGrids;
 
 type
   TForm1 = class(TForm)
     DBGrid1: TDBGrid;
     MyTable: TTable;
     DataSource1: TDataSource;
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     procedure ExportToASCII;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.ExportToASCII;
 const
   FASCIISeparator:string=' | ';
 var
   I: Integer;
   Dlg: TSaveDialog;
   ASCIIFile: TextFile;
   Res, FASCIIFieldNames: Boolean;
   FASCIIFileName:string;
 begin
   with MyTable do
   begin
     if Active then
       if (FieldCount > 0) and (RecordCount > 0) then
       begin
         Dlg := TSaveDialog.Create(Application);
         Dlg.FileName := FASCIIFileName;
         Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';
         Dlg.Options := Dlg.Options+[ofPathMustExist,
         ofOverwritePrompt, ofHideReadOnly];
         Dlg.Title := 'Экспоритровать данные в ASCII-файл';
         try
           Res := Dlg.Execute;
           if Res then
             FASCIIFileName := Dlg.FileName;
         finally
           Dlg.Free;
         end;
         if Res then
         begin
           AssignFile(ASCIIFile, FASCIIFileName);
           Rewrite(ASCIIFile); First;
           if FASCIIFieldNames then
           begin
             for I := 0 to FieldCount-1 do
             begin
               write(ASCIIFile, Fields[I].FieldName);
               if I <> FieldCount-1 then
                 write(ASCIIFile, FASCIISeparator);
             end;
             write(ASCIIFile, #13#10);
           end;
           while not EOF do
           begin
             for I := 0 to FieldCount-1 do
             begin
               write(ASCIIFile, Fields[I].Text);
               if I <> FieldCount-1 then
                 write(ASCIIFile, FASCIISeparator);
             end;
             Next;
             if not EOF then
               write(ASCIIFile, #13#10);
           end;
           CloseFile(ASCIIFile);
           if IOResult <> 0 then
             MessageDlg('Ошибка при создании или переписывании '+
             'в ASCII-файл', mtError, [mbOK], 0);
         end;
       end
       else
         MessageDlg('Нет данных для экспортирования.',
         mtInformation, [mbOK], 0)
     else
       MessageDlg('Таблица должна быть открытой, чтобы данные '+
       'можно было экспортировать в ASCII-формат.', mtError, [mbOK], 0);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ExportToASCII;
 end;
 
 end.
 




Экспорт из Paradox в ASCII файл с кодовой страницей 852


 function ConvertTo852(S: string): string;
 var
   A : integer;
   Ch : char;
 begin
   setlength(Result,Length(S));
   for A := 1 to length(S) do
   begin
     case S[A] of
       <code>: Ch := <852code>
       <code2>: Ch := <852code2>
       ...
       else Ch := S[A];
     end;
       Result[A] := Ch;
   end;
 end;
 




Экспорт информации из базы данных в Word

Автор: Uncle B.

Если используешь шаблон, то вариант такой:
1. В шаблоне Word'a в нужные места расставляешь Bookmark (Insert->Bookmark).
2. В проге позиционируешь на этот букмарк и пишешь данные.


 (WrdApp - TWordApplication)
 
 procedure TfrmPToClient.bbCreateClick(Sender: TObject);
 var
   InvoiceTemplate: OleVariant;
 begin
   // Соединение с OLE-сервером
   WrdApp.Connect;
   WrdApp.Visible := True;
   // выбор шаблона
   if not FileExists(dlgOpen.FileName) then
     Exit;
   InvoiceTemplate := edFileName.Text;
   // открытие выбраного шаблона в Word'e
   WrdApp.Documents.Add(InvoiceTemplate, EmptyParam);
   WordGotoBookmark('PDate');
   WordInsertText(' ' + DateToStr(dtpPDate.Date));
   WordGotoBookmark('PNr');
   WordInsertText(' ' + edPNr.Text);
   WordGotoBookmark('PClientName');
   WordInsertText(' ' +
     dmIB_TOIS.tblProject.FieldByName('ProjectClientName').asString);
   WordGotoBookmark('ContractNr');
   WordInsertText(' ' + dmIB_TOIS.tblProject.FieldByName('CLWordGotoBookmark('
     ContractDate');
     WordInsertText(' ' +
       dmIB_TOIS.tblProject.FieldByName('CL_ContractDate').asString);
     WordGotoBookmark('PCargoName');
     WordInsertText(' ' +
       dmIB_TOIS.tblProjectCargo.FieldByName('CargoName').asString);
     WordGotoBookmark('PProjectYear');
     WordInsertText(' ' +
       dmIB_TOIS.tblProject.FieldByName('PROJECTNOTICEYEAR').asString);
     WordGotoBookmark('PProjectMonth');
     WordInsertText(' ' +
       arMonths[dmIB_TOIS.tblProject.FieldByName('PROJECTNOTICEMonth').asInteger]);
 end;
 
 procedure TfrmPToClient.WordGotoBookmark(Bookmark: string);
 var
   What: OLEVariant;
   Which: OLEVariant;
   Count: OLEVariant;
   Name: OLEVariant;
 begin
   What := wdGoToBookmark;
   Which := unAssigned;
   Count := unAssigned;
   Name := Bookmark;
   WrdApp.Selection.GoTo_(What, Which, Count, Name);
 end;
 
 procedure TfrmPToClient.WordInsertText(Text: string);
 begin
   WrdApp.Selection.TypeText(Text);
 end;
 

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

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




Компилятор синтаксических выражений

Автор: Сергей Втюрин aka Nemo

Что это и зачем или Немного наглой саморекламы

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

Что он может или Какие мы маленькие

Да в общем-то немного, и ценности в ней мало :). Она может вычислять выражения (тип - вещественное число с плавающей точкой (на момент написания это называлось Real)) с использованием операций (+,-,/,*). Мало... А разве сложно дописать пару строк чтобы обработать Y или экспоненту коли они будут нужны?

Так зачем же это нужно.

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

Отдельное спасибо

(да я знаю, что благодарности помещают в конце, но там их редко кто читает :)) так вот отдельное спасибо: Спасибо человеку, который сделал из меня программиста. Спасибо Королеве Елене Филипповой. Если вы здесь, то вы знаете за что.:) Эта программа написана в то время когда меня можно было легко "взять на "слабо"". Так вот спасибо тому кто меня подначил на ее написание :)

Но к делу

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

Как все это работает:

Компилятор он и есть компилятор. Сначала выражение надо скомпилировать. Делается это с помощью функции

 function Prepare(Ex:String):real;
 

которая вызывает

 function preCalc(Ex:String):real;
 

формирующую код, вычисляющий заданное выражение. Как можно догадаться, Ex - это строка, содержащая математическое выражение. Функция preCalc рекурсивна и распознавая полученную математику, попутно формируя исполняемый код. Она имеет мало проверок на корректность и нет нужды вводить туда мусор и радоваться, когда увидите что все повисло. Помните правило GIGO (Garbage in Garbage Out). Не надо также ставить 0 под знак деления. Но это уже не моя ошибка :)))

ВНИМАНИЕ:

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

Для понятности формируемый код представляется в ближайшем Memo. Функция возвращает: а фиг его знает что она возвращает :) лучше не обращайте внимания :) Скомпилировали? Теперь можно и запускать: При компиляции мы сформировали процедуру с красноречивым названием:

 proc:TProc;
 

где

 type TProc=procedure;
 

пример запуска можно найти в

 procedure TForm1.BitBtn1Click(Sender: TObject);
 

Также встречаются процедуры и функции:

 function SecindBracket(Ex:String;first:integer):Integer;
 

вот уж и не помню, отчего появилось такое красивое название (скорее всего от очепятки), но все это призвано обработать скобки в выражении ,

 procedure TForm1.BitBtn1Click(Sender: TObject); // Вычисляй
 

запускает вычисление, а также

 procedure TForm1.Button2Click(Sender: TObject); // Speed test
 

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

 I:=0; // обнуляем счетчик
 

а по структуре программы там комментариев хватает. Ну вот и все... Буду рад если вам это пригодиться. Если какие пожелания - пишите. Конструктивная критика - пишите. Неконструктивная критика - тоже пишите - у меня файлы удаляются без помещения в корзину.


 // Это Unit1.pas
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Buttons, StrEx, Math;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     BitBtn1: TBitBtn;
     Label1: TLabel;
     Memo1: TMemo;
     Button1: TButton;
     Edit2: TEdit;
     Label2: TLabel;
     Button2: TButton;
     procedure BitBtn1Click(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Edit1Change(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
   TProc = procedure;
 
 var
   Form1: TForm1;
   A: array of real;
   CS: array of Byte;
   DS: array of Real;
   Res, X, Y: real;
   proc: TProc;
 
 function preCalc(Ex: string): real;
 function Prepare(Ex: string): real;
 function SecindBracket(Ex: string; first: integer): Integer;
 
 implementation
 {$R *.DFM}
 
 //      это про скобки... это просто и не заслуживает большого внимания.
 
 function SecindBracket(Ex: string; first: integer): Integer;
 var
   i, BrQ: integer;
 begin
   Result := 0;
   case Ex[first] of
     '(':
       begin
         i := first + 1;
         BrQ := 0;
         while (i <= length(Ex)) do
         begin
           if (BrQ = 0) and (Ex[i] = ')') then
           begin
             Result := i;
             exit;
           end;
           if Ex[i] = '(' then
             Inc(BrQ)
           else if Ex[i] = ')' then
             Dec(BrQ);
           i := i + 1;
         end;
       end;
     ')':
       begin
         i := first - 1;
         BrQ := 0;
         while (i > 0) do
         begin
           if (BrQ = 0) and (Ex[i] = '(') then
           begin
             Result := i;
             exit;
           end;
           if Ex[i] = '(' then
             Inc(BrQ)
           else if Ex[i] = ')' then
             Dec(BrQ);
           i := i - 1;
         end;
       end;
   end;
 end;
 
 //      а вот тут мы собственно и формируем процедуру
 
 function Prepare(Ex: string): real;
 begin
   SetLength(Ds, 1);
 
   //      вот это будет заголовок
   SetLength(CS, 6);
   cs[0] := $8B;
   cs[1] := $05;
   cs[2] := (integer(@ds) and $000000FF) shr 0;
   cs[3] := (integer(@ds) and $0000FF00) shr 8;
   cs[4] := (integer(@ds) and $00FF0000) shr 16;
   cs[5] := (integer(@ds) and $FF000000) shr 24;
 
   //      вот это - вычисление
   X := 1; //догадайтесь зачем :)
   preCalc(Ex);
 
   //      а вот это - завершение
   SetLength(CS, high(CS) + 7);
   cs[high(CS) - 5] := $DD;
   cs[high(CS) - 4] := $1D;
   cs[high(CS) - 3] := (integer(@res) and $000000FF) shr 0;
   cs[high(CS) - 2] := (integer(@res) and $0000FF00) shr 8;
   cs[high(CS) - 1] := (integer(@res) and $00FF0000) shr 16;
   cs[high(CS) - 0] := (integer(@res) and $FF000000) shr 24;
 
   SetLength(CS, high(CS) + 2);
 
   //      ну и не забудем про RET
   cs[high(CS)] := $C3; // ret
 
   proc := pointer(cs);
 end;
 
 //      будем формировать код рассчета.
 
 function preCalc(Ex: string): real;
 
 var
   Sc, i, j: integer;
   s, s1: string;
   A, B: real;
 
 const
   Op: array[0..3] of char = ('+', '-', '/', '*');
 
 begin
 
   s := ''; //      да всегда инициализируйте переменные ваши
   for i := 1 to length(Ex) do
     if ex[i] <> ' ' then
       s := s + ex[i];
   // чтобы под ногами не путались :)
 
   while SecindBracket(s, Length(s)) = 1 do
     s := copy(s, 2, Length(s) - 2); // скобки
 
   if s = '' then
   begin
     Result := 0;
     ShowMessage('Error !');
     exit;
   end;
 
   val(s, Result, i); // это число ? а какое ?
 
   if i = 0 then
   begin //      ага это число. так и запишем
     Form1.Memo1.Lines.Add('fld ' + FloatToStr(result));
     SetLength(Ds, high(ds) + 2);
     Ds[high(ds)] := Result;
 
     SetLength(CS, high(CS) + 4);
     cs[high(Cs)] := high(ds) * 8;
     cs[high(Cs) - 1] := $40;
     cs[high(Cs) - 2] := $DD;
     exit;
   end;
   if (s = 'x') or (s = 'X') then
   begin //      опа, да это же Икс !
     Form1.Memo1.Lines.Add('fld X');
     SetLength(CS, high(CS) + 7);
     cs[high(CS) - 5] := $DD;
     cs[high(CS) - 4] := $05;
     cs[high(CS) - 3] := (integer(@x) and $000000FF) shr 0;
     cs[high(CS) - 2] := (integer(@x) and $0000FF00) shr 8;
     cs[high(CS) - 1] := (integer(@x) and $00FF0000) shr 16;
     cs[high(CS) - 0] := (integer(@x) and $FF000000) shr 24;
   end;
 
   // это все еще выражение :( ох не кончились наши мучения
   i := -1;
   j := 0;
   while j <= 1 do
   begin
     i := length(s);
     Sc := 0;
     while i > 0 do
     begin // ну скобки надо обойти
       if s[i] = ')' then
         Inc(Sc);
       if s[i] = '(' then
         Dec(Sc);
       if Sc <> 0 then
       begin
         dec(i);
         continue;
       end;
       if (s[i] = Op[j * 2]) then
       begin
         j := j * 2 + 10;
         break;
       end;
       if (s[i] = Op[j * 2 + 1]) then
       begin
         j := j * 2 + 11;
         break;
       end;
       dec(i);
     end;
     inc(j);
   end;
 
   //('+','-','/','*');
   // а вот и рекурсия - все что справа и слева от меня пусть обработает ...
   // ой да это же я:) Ну а я так уж и быть сформирую код операции в середине :)
   case j of
     11:
       begin
         preCalc(copy(s, 1, i - 1));
         preCalc(copy(s, i + 1, length(s) - i));
         Form1.Memo1.Lines.Add('FAddp St(1),st');
         // cs
         //fAddP st(1),st       //  [DE C1]
         SetLength(CS, high(CS) + 3);
         cs[high(Cs)] := $C1; //      вот такой код сформируем
         cs[high(Cs) - 1] := $DE;
       end;
     //      далее - аналогично для каждой операции
     12:
       begin
         preCalc(copy(s, 1, i - 1));
         preCalc(copy(s, i + 1, length(s) - i));
         Form1.Memo1.Lines.Add('FSubP St(1),st');
         //fSubP st(1),st       //  [DE E9]
         SetLength(CS, high(CS) + 3);
         cs[high(Cs)] := $E9;
         cs[high(Cs) - 1] := $DE;
       end;
     13:
       begin
         try
           preCalc(copy(s, 1, i - 1));
           preCalc(copy(s, i + 1, length(s) - i));
           Form1.Memo1.Lines.Add('fdivP st(1),st');
           //fDivP st(1),st       //  [DE F9]
           SetLength(CS, high(CS) + 3);
           cs[high(Cs)] := $F9;
           cs[high(Cs) - 1] := $DE;
         except
           ShowMessage('Division by zero !... ');
           preCalc(copy(s, 1, i - 1));
           preCalc(copy(s, i + 1, length(s) - i));
           exit;
         end;
       end;
     14:
       begin
         preCalc(copy(s, 1, i - 1));
         preCalc(copy(s, i + 1, length(s) - i));
         Form1.Memo1.Lines.Add('FMulp St(1),st');
         //fMulP st(1),st       //  [DE C9]
         SetLength(CS, high(CS) + 3);
         cs[high(Cs)] := $C9;
         cs[high(Cs) - 1] := $DE;
       end;
   end;
 end;
 
 //      Вычисляй
 
 procedure TForm1.BitBtn1Click(Sender: TObject);
 begin
   x := StrToFloat(Edit2.text);
   if (@proc <> nil) then
     proc; //      Вычисляй
   Label1.caption := FloatToStr(res);
 end;
 
 //      это всякие сервисные функции
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Memo1.Clear;
   Prepare(Edit1.text);
   BitBtn1.Enabled := true;
 end;
 
 procedure TForm1.Edit1Change(Sender: TObject);
 begin
   BitBtn1.Enabled := false;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Edit1.OnChange(self);
 end;
 
 // а это для того чтобы посмотреть какой за быстрый получился код
 
 procedure TForm1.Button2Click(Sender: TObject); //Speed test
 var
   t: TDateTime;
   i: integer;
 const
   N = $5000000; //количество повторений
 begin
   if @proc = nil then
     exit;
   t := now;
   for i := 0 to N do
   begin
     x := i;
     proc;
     x := res;
   end;
   t := now - t;
   Memo1.lines.add('work time for ' + inttostr(N) + ' repeats =' + TimeToStr(t) +
     ' sec');
   Memo1.lines.add('=' + FloatToStr(t) + ' days');
 end;
 
 end.
 
 // а это Unit1.dfm
 
 object Form1: TForm1
   Left = 175
     Top = 107
     Width = 596
     Height = 375
     Caption = 'Form1'
     Color = clBtnFace
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     OldCreateOrder = False
     OnCreate = FormCreate
     PixelsPerInch = 96
     TextHeight = 13
     object Label1: TLabel
     Left = 448
       Top = 56
       Width = 6
       Height = 13
       Caption = '[]'
   end
   object Label2: TLabel
     Left = 19
       Top = 12
       Width = 13
       Height = 13
       Caption = 'X='
   end
   object Edit1: TEdit
     Left = 16
       Top = 32
       Width = 417
       Height = 21
       TabOrder = 0
       Text = '((24/2)+3*(7-x))'
       OnChange = Edit1Change
   end
   object BitBtn1: TBitBtn
     Left = 448
       Top = 32
       Width = 75
       Height = 22
       TabOrder = 1
       OnClick = BitBtn1Click
       Kind = bkOK
   end
   object Memo1: TMemo
     Left = 16
       Top = 80
       Width = 241
       Height = 249
       TabOrder = 2
   end
   object Button1: TButton
     Left = 448
       Top = 2
       Width = 75
       Height = 25
       Caption = 'prepare'
       TabOrder = 3
       OnClick = Button1Click
   end
   object Edit2: TEdit
     Left = 36
       Top = 8
       Width = 53
       Height = 21
       TabOrder = 4
       Text = '2'
   end
   object Button2: TButton
     Left = 264
       Top = 80
       Width = 75
       Height = 25
       Caption = 'Speed test'
       TabOrder = 5
       OnClick = Button2Click
   end
 end
 




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

Сонник для копьютерщиков. Если вам приснился сон с расширением:
-.ехе,.bаt - он обязательно исполнится;
-.оbj - несвязный сон;
-.htm(l) - к Интернету;
-.jрg - без комментариев;
-.раr - опять чертов будильник не дал досмотреть до конца.

   LTrim()     - Удаляем все пробелы в левой части строки
   RTrim()     - Удаляем все пробелы в правой части строки
   Trim()      - Удаляем все пробелы по краям строки
   RightStr()  - Возвращаем правую часть стоки заданной длины
   LeftStr()   - Возвращаем левую часть стоки заданной длины
   MidStr()    - Возвращаем центральную часть строки
   squish()    - возвращает строку со всеми белыми пробелами и с удаленными повторяющимися апострофами.
   before()    - возвращает часть стоки, находящейся перед первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает Search.
   after()     - возвращает часть строки, находящейся после первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает NULL.
   RPos()      - возвращает первый символ последней найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает 0. Подобна реверсированной Pos().
   inside()    - возвращает подстроку, вложенную между парой подстрок Front ... Back.
   leftside()  - возвращает левую часть "отстатка" inside() или Search.
   rightside() - возвращает правую часть "остатка" inside() или Null.
   trim()      - возвращает строку со всеми удаленными по краям белыми пробелами.
 

 unit TrimStr;
 {$B-}
 {
 Файл: TrimStr
 Автор: Bob Swart [100434,2072]
 Описание: программы для удаления конечных/начальных пробелов
 и левых/правых частей строк (аналог Basic-функций).
 Версия: 2.0
 
 LTrim()    - Удаляем все пробелы в левой части строки
 RTrim()    - Удаляем все пробелы в правой части строки
 Trim()     - Удаляем все пробелы по краям строки
 RightStr() - Возвращаем правую часть стоки заданной длины
 LeftStr()  - Возвращаем левую часть стоки заданной длины
 MidStr()   - Возвращаем центральную часть строки
 
 }
 interface
 const
   Space = #$20;
 
 function LTrim(const Str: string): string;
 function RTrim(Str: string): string;
 function Trim(Str: string): string;
 function RightStr(const Str: string; Size: Word): string;
 function LeftStr(const Str: string; Size: Word): string;
 function MidStr(const Str: string; Size: Word): string;
 
 implementation
 
 function LTrim(const Str: string): string;
 var
   len: Byte absolute Str;
   i: Integer;
 begin
   i := 1;
   while (i <= len) and (Str[i] = Space) do
     Inc(i);
   LTrim := Copy(Str, i, len)
 end {LTrim};
 
 function RTrim(Str: string): string;
 var
   len: Byte absolute Str;
 begin
   while (Str[len] = Space) do
     Dec(len);
   RTrim := Str
 end {RTrim};
 
 function Trim(Str: string): string;
 begin
   Trim := LTrim(RTrim(Str))
 end {Trim};
 
 function RightStr(const Str: string; Size: Word): string;
 var
   len: Byte absolute Str;
 begin
   if Size > len then
     Size := len;
   RightStr := Copy(Str, len - Size + 1, Size)
 end {RightStr};
 
 function LeftStr(const Str: string; Size: Word): string;
 begin
   LeftStr := Copy(Str, 1, Size)
 end {LeftStr};
 
 function MidStr(const Str: string; Size: Word): string;
 var
   len: Byte absolute Str;
 begin
   if Size > len then
     Size := len;
   MidStr := Copy(Str, ((len - Size) div 2) + 1, Size)
 end {MidStr};
 
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 const
   BlackSpace = [#33..#126];
 
   {
   squish() возвращает строку со всеми белыми пробелами и с удаленными
   повторяющимися апострофами.
   }
 
 function squish(const Search: string): string;
 var
 
   Index: byte;
   InString: boolean;
 begin
 
   InString := False;
   Result := '';
   for Index := 1 to Length(Search) do
   begin
     if InString or (Search[Index] in BlackSpace) then
       AppendStr(Result, Search[Index]);
     InString := ((Search[Index] = '''') and (Search[Index - 1] <> '\'))
       xor InString;
   end;
 end;
 
 {
 
 before() возвращает часть стоки, находящейся перед
 первой найденной подстроки Find в строке Search. Если
 Find не найдена, функция возвращает Search.
 }
 
 function before(const Search, Find: string): string;
 var
 
   index: byte;
 begin
 
   index := Pos(Find, Search);
   if index = 0 then
     Result := Search
   else
     Result := Copy(Search, 1, index - 1);
 end;
 
 {
 
 after() возвращает часть строки, находящейся после
 первой найденной подстроки Find в строке Search. Если
 Find не найдена, функция возвращает NULL.
 }
 
 function after(const Search, Find: string): string;
 var
 
   index: byte;
 begin
 
   index := Pos(Find, Search);
   if index = 0 then
     Result := ''
   else
     Result := Copy(Search, index + Length(Find), 255);
 end;
 
 {
 
 RPos() возвращает первый символ последней найденной
 подстроки Find в строке Search. Если Find не найдена,
 функция возвращает 0. Подобна реверсированной Pos().
 }
 
 function RPos(const Find, Search: string): byte;
 var
 
   FindPtr, SearchPtr, TempPtr: PChar;
 begin
 
   FindPtr := StrAlloc(Length(Find) + 1);
   SearchPtr := StrAlloc(Length(Search) + 1);
   StrPCopy(FindPtr, Find);
   StrPCopy(SearchPtr, Search);
   Result := 0;
   repeat
     TempPtr := StrRScan(SearchPtr, FindPtr^);
     if TempPtr <> nil then
       if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then
       begin
         Result := TempPtr - SearchPtr + 1;
         TempPtr := nil;
       end
       else
         TempPtr := #0;
   until TempPtr = nil;
 end;
 
 {
 
 inside() возвращает подстроку, вложенную между парой
 подстрок Front ... Back.
 }
 
 function inside(const Search, Front, Back: string): string;
 var
 
   Index, Len: byte;
 begin
 
   Index := RPos(Front, before(Search, Back));
   Len := Pos(Back, Search);
   if (Index > 0) and (Len > 0) then
     Result := Copy(Search, Index + 1, Len - (Index + 1))
   else
     Result := '';
 end;
 
 {
 
 leftside() возвращает левую часть "отстатка" inside() или Search.
 }
 
 function leftside(const Search, Front, Back: string): string;
 begin
 
   Result := before(Search, Front + inside(Search, Front, Back) + Back);
 end;
 
 {
 
 rightside() возвращает правую часть "остатка" inside() или Null.
 }
 
 function rightside(const Search, Front, Back: string): string;
 begin
 
   Result := after(Search, Front + inside(Search, Front, Back) + Back);
 end;
 
 {
 
 trim() возвращает строку со всеми удаленными по краям белыми пробелами.
 }
 
 function trim(const Search: string): string;
 var
 
   Index: byte;
 begin
 
   Index := 1;
   while (Index <= Length(Search)) and not (Search[Index] in BlackSpace) do
     Index := Index + 1;
   Result := Copy(Search, Index, 255);
   Index := Length(Result);
   while (Index > 0) and not (Result[Index] in BlackSpace) do
     Index := Index - 1;
   Result := Copy(Result, 1, Index);
 end;
 




Извлечение из EXE-файла иконки и рисование ее в TImage

Сперва для получения дескриптора иконки используйте вызов API ExtractIcon, затем назначьте (assign) ее TImage.

Далее смотри электронную документацию.




Извлечение из EXE-файла иконки и рисование ее в TImage 2


 uses ShellApi;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   IconIndex: word;
   h: hIcon;
 begin
   IconIndex := 0;
   h := ExtractAssociatedIcon(hInstance,
     'C:\WINDOWS\NOTEPAD.EXE', IconINdex);
 
   DrawIcon(Form1.Canvas.Handle, 10, 10, h);
 end;
 




Как извлечь ID3 теги и информацию в заголовках MPEG из MP3 файлов

Автор: Андрей Сорокин
WEB-сайт: http://anso.da.ru

- Папа, а что такое ноты?
- Понимаешь, сынок, это такой MIDI-файл, только на бумаге...

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

Разместите на форме TEdit для имени каталога и TListBox для содержимого директории и вызовите:


 ScanMP3Folder(Edit1.Text, ListBox1.Items);
 

Вам потребуются компоненты TAudioInfo , и  TDirectoryScanner


 procedure ScanMP3Folder (const AFolder : string; AMP3List : TStrings);
 var
   ds : TDirectoryScanner;
   a : TAudioInfo;
   Descr : string;
   i : integer;
 begin
   ds := TDirectoryScanner.Create;
   a := TAudioInfo.Create;
   try
     ds.Recursive := True;
     ds.RegExprMask := '\.mp[23]';
     ds.BuildFileList (AFolder);
     for i := 0 to ds.Count - 1 do
     begin
       a.LoadFromFile (ds.Item [i].name);
       if a.ID3.Ok then
         Descr := a.ID3.Artist + ' - ' + a.ID3.Title
       else
         Descr := ExtractFileName (ds.Item [i].name);
       Descr := Descr + Format (' (%d sec)', [a.MpegDuration div 1000]);
       AMP3List.Add (Descr);
     end;
   finally
     begin
       a.Free;
       ds.Free;
     end;
   end;
 end;
 




Выдавить текст

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

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


 const
   s = 'It is a text string';
   ColDark = clGray;
   ColNorm = clSilver;
   ColLight = clWhite;
   XPos = 10;
   YPos = 10;
   dx = 1;
   dy = 1;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.Canvas.Brush.Style := bsClear;
   with Form1.Canvas.Font do
   begin
     name := 'Arial';
     Size := 20;
     Style := [fsBold];
   end;
 end;
 
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   with Form1.Canvas do
   begin
     Font.Color := ColDark;
     TextOut(XPos - dx, YPos - dy, s);
     Font.Color := ColLight;
     TextOut(XPos + dx, YPos + dy, s);
     Font.Color := ColNorm;
     TextOut(XPos, YPos, s);
   end;
 end;
 
 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   with Form1.Canvas do
   begin
     Font.Color := ColLight;
     TextOut(XPos - dx, YPos - dy, s);
     Font.Color := ColDark;
     TextOut(XPos + dx, YPos + dy, s);
     Font.Color := ColNorm;
     TextOut(XPos, YPos, s);
   end;
 end;
 
 procedure TForm1.FormPaint(Sender: TObject);
 begin
   Form1.MouseUp(mbLeft, [], 0, 0);
 end;
 




Расширение компонента ListBox

Да освятится имя твое и расширение твое, Господи... Да поможет нам , и да сохранит нас .

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

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

Вот код.


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TTraQsListBox = class(TListBox)
   private
     FDoubleClickBtn: TButton;
   protected
     procedure DblClick; override;
   public
   published
     property DoubleClickBtn: TButton read FDoubleClickBtn write FDoubleClickBtn;
   end;
 
 procedure Register;
 
 implementation
 
 {TTraQsListBox}
 
 procedure TTraQsListBox.DblClick;
 begin
   if Assigned(FDoubleClickBtn) then
     FDoubleClickBtn.Click
   else
     inherited DblClick;
 end;
 
 procedure Register;
 begin
   RegisterComponents('My Components', [TTraQsListBox]);
 end;
 
 end.
 




Дополненный TRegistry, умеет работать с значениями типа REG_MULTI_SZ (Windows XP, Windows 7)

Автор: Кондратюк Виталий

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


 unit Reg;
 {$R-,T-,H+,X+}
 
 interface
 
 uses Registry, Classes, Windows, Consts, SysUtils;
 
 type
 
   TReg = class(TRegistry)
   public
     procedure ReadStringList(const name: string; list: TStringList);
     procedure WriteStringList(const name: string; list: TStringList);
   end;
 
 implementation
 
 //*** TReg *********************************************************************
 //------------------------------------------------------------------------------
 // Запись TStringList ввиде значения типа REG_MULTI_SZ в реестр
 //------------------------------------------------------------------------------
 
 procedure TReg.WriteStringList(const name: string; list: TStringList);
 var
 
   Buffer: Pointer;
   BufSize: DWORD;
   i, j, k: Integer;
   s: string;
   p: PChar;
 begin
 
   {подготовим буфер к записи}
   BufSize := 0;
   for i := 0 to list.Count - 1 do
     inc(BufSize, Length(list[i]) + 1);
   inc(BufSize);
   GetMem(Buffer, BufSize);
   k := 0;
   p := Buffer;
   for i := 0 to list.Count - 1 do
   begin
     s := list[i];
     for j := 0 to Length(s) - 1 do
     begin
       p[k] := s[j + 1];
       inc(k);
     end;
     p[k] := chr(0);
     inc(k);
   end;
   p[k] := chr(0);
 
   {запись в реестр}
   if RegSetValueEx(CurrentKey, PChar(name), 0, REG_MULTI_SZ, Buffer,
     BufSize) <> ERROR_SUCCESS then
     raise ERegistryException.CreateResFmt(@SRegSetDataFailed, [name]);
 end;
 //------------------------------------------------------------------------------
 // Чтение TStringList ввиде значения типа REG_MULTI_SZ из реестра
 //------------------------------------------------------------------------------
 
 procedure TReg.ReadStringList(const name: string; list: TStringList);
 var
 
   BufSize,
     DataType: DWORD;
   Len, i: Integer;
   Buffer: PChar;
   s: string;
 begin
 
   if list = nil then
     Exit;
   {чтение из реестра}
   Len := GetDataSize(Name);
   if Len < 1 then
     Exit;
   Buffer := AllocMem(Len);
   if Buffer = nil then
     Exit;
   try
     DataType := REG_NONE;
     BufSize := Len;
     if RegQueryValueEx(CurrentKey, PChar(name), nil, @DataType, PByte(Buffer),
       @BufSize) <> ERROR_SUCCESS then
       raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [name]);
     if DataType <> REG_MULTI_SZ then
       raise ERegistryException.CreateResFmt(@SInvalidRegType, [name]);
     {запись в TStringList}
     list.Clear;
     s := '';
     for i := 0 to BufSize - 2 do
     begin // BufSize-2 т.к. последние два нулевых символа
       if Buffer[i] = chr(0) then
       begin
         list.Add(s);
         s := '';
       end
       else
         s := s + Buffer[i];
     end;
   finally
     FreeMem(Buffer);
   end;
 end;
 
 end.
 




Как ListView перевести в режим редактирования по нажатию на F2


На днях одеваюсь, достал из шкафа футболку, просунул руки в рукава и выворачиваю(а то мамка любит все футболки вывернутыми на изнанку в шкаф складывать)...Вывернул. Смотрю - а она наизнанку вывернута. Первая мысль - "Где тут Undo нажимается?"...


 procedure TForm1.ListView1KeyDown(Sender: TObject;
   var Key: Word; Shift: TShiftState);
 begin
   if Ord(Key) = VK_F2 then
     ListView1.Selected.EditCaption;
 end;
 




Процедура для нахождения точного значения факториала числа

Процедура для нахождения точного значения факториала числа.

Вы когда-нибудь находили факториал 10? - это легко, а 20?,а 100? Даже с помощью самого продвинутого калькулятора это не получится, (имею в виду точное значение, например в 100!-158 цифр, какой должен быть дисплей калькулятора, чтобы показать такое значение??!)C помощью программы содержащей алгоритм похожий на описанный, это можно сделать. Для такой программы нужна форма(form, содержащая такие компоненты Memo(имя в процедуре mmOutput), Maskedit(med),ProgressBar(PB-это не обязательно, но если считаешь очень большой факториал, то это занимает некоторое время, поэтому визуально следить за временем, оставшимся на вычисление, очень удобно). Идея программы: переменные в Delphi не могут содержать таких длинных чисел, поэтому здесь используется массив целых переменных, обрабатывая который и получаем нужный ответ. В результате можно считать факториалы многотысячных чисел, я считал 5000!,дальше считать долго, но возможно.


 procedure TForm1.bbRunClick(Sender: TObject); //обработка события от мыши
 var //это раздел указания переменных
   result: string; //переменная result целого типа
   M: array of integer;
     //"M"- это матрица, или массив, причем динамический, то есть его размеры можно
   F, i, j, k, n: integer;
     //изменять, это увеличивает время выполнения программы, но интересно попробовать
 begin
   if med.text = '' then
     med.text := '0'; //свойство text компонента med проверяется на наличие
   n := StrToInt(Trim(MEd.Text));
     //введенного числа, StrToInt-преобразование строки в число
   if n < 4 then
     exit; //trim-удаление пробелов из строки
   PB.Max := (n + sqr(n)); //Это определение размеров PB
   PB.Position := 0;
   screen.Cursor := crHourGlass;
     //появляется новый курсор, стандартный "виндовский"
   setLength(M, 2); //определение границ массива
   M[0] := 1; //присвоение 0-ому элементу массива М значения 1....
   M[1] := 0;
   k := 1;
   for i := 1 to n do
   begin
     F := 0;
     PB.StepBy(i * 2); //изменение показаний PB
     for j := 0 to k do
     begin
       SetLength(M, k + 1);
       M[j] := M[j] * i + F; //здесь основная идея программы
       if (M[j] div 10) > 0 then
         k := k + 1;
       F := M[j] div 10;
       M[j] := M[j] mod 10;
     end;
   end;
   for i := k downto 0 do //перебор целых значений от k до 0
   begin
     if M[i] > 0 then
       break;
     if M[i] = 0 then
       k := k - 1;
   end;
   SetLength(M, k); //изменение размеров массива М до кол-ва элементов-k
   Result := '';
   for j := k downto 0 do
     Result := Result + IntToStr(M[j]);
   mmOutput.Lines.Add(IntToStr(n) + '! = ' + result);
     //добавление результата в редактор Memo(mmOutput)
   if n6.Checked = true then
     mmoutput.Lines.Add('В этом числе ' + IntToStr(length(result)) + ' цифр.');
   M := nil; //освобождение памяти IntToStr-преобразование числа в строку
   screen.Cursor := crDefault; //смена курсора
   Med.Text := '';
   Med.SetFocus; //передача фокуса ввода компоненту med
 end;
 




FastReport - Разработка кросс-платформенных отчетов

Автор: Михаил Филиппенко
WEB-сайт: FastReport Software

Еще со времен Ады Ловлес разработчики программного обеспечения пытаются облегчить себе жизнь. И, без сомнения, это им удается.

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

Давно прошли те времена, когда разработчику каждого приложения приходилось каждый раз изобретать формат базы данных, отчет и интерфейс. Можно увидеть, как за короткий срок базы и банки данных выделились в отдельную группу, приложения и интерфейсная часть в другую, генераторы отчетов - в третью. Благодаря таким средствам разработки как MS VisualC, Visual Basic, C# и Borland Delphi разработка серьезных приложений, работающих с базами данных, сегодня превратилась в некоторое подобие детского конструктора, в котором что угодно можно собрать из отдельных "кубиков".

Такой "кубик" как генераторы отчетов выделился в отдельную и немаловажную часть в разработках относительно недавно, однако и здесь есть богатейший выбор инструментов для построения отчетных форм (именно их, зачастую, в конечном счете требует заказчик). Для того же Borland Delphi вы можете воспользоваться как встроенными средствами, идущими в комплекте c Borland Delphi и Borland Visual C++Builder - QuickReport ак и более "продвинутыми" продуктами от других разработчиков, это Crystal Reports от Seagate Software (ныне Crystal Software), представляющий собой вполне самостоятельный продукт, имеющий компоненты, дающие доступ к его возможностям из любой популярной сегодня среды разработки, будь то Borland Delphi, MS Visual C или MS Visual Basic, это и ReportBuilder от компании DigitalMetaphors (по опросу DelphiZine вот уже несколько лет признаваемый самым популярным инструментом для разработки отчетов в Delphi), это и ReportPrinter (ныне Rave) от Nevrona Design, а также FastReport (по тому же опросу поделившие второе и третье место в 2001 году и вышедший на стабильное второе место в 2002 году).

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

  • Бэнд-ориентированный генератор отчетов.
  • Встроенный мощный дизайнер, доступный и в run-time.
  • WYSIWYG предварительный просмотр как в MS Word (т.е. мы можем видеть одновременно несколько страниц отчета).
  • Скорость работы сравнима с QuickReport.
  • Компактность кода - без дизайнера меньше, чем QuickReport3.
  • Неограниченное количество страниц сформированного отчета.
  • Многостраничные отчеты; составные (композитные) отчеты; вложенные отчеты; группы; многоколоночные отчеты; master-detail-detail отчеты; cross-tab отчеты; двухпроходные отчеты; "живые" отчеты.
  • Полный контроль над процессом печати, поддержка всех типов бумаги.
  • Набор наиболее популярных компонентов: Текст, Линия, Рисунок, Фигура, OLE объект, RichText, RX Rich 2.0, Диаграмма, Штрих-код.
  • Экспорт в TXT, RTF, CSV, HTML (в RTF, HTML - с картинками).
  • Поиск текста в сформированном отчете.
  • Редактирование сформированного отчета.
  • Встроенный интерпретатор Pascal-подобного языка для управления процессом построения отчета.
  • Набор визуальных компонентов для создания диалоговых форм;
  • Набор невизуальных компонентов для создания таблиц, запросов и баз данных;
  • Работа с BDE, Interbase Express (IBX), ActiveX Data Objects (ADO).
  • Работа как с Database - ориентированными источниками данных, так и с любыми данными.
  • Форма отчета может храниться как в DFM, так и во внешнем файле.
  • Функциональность может быть расширена за счет написания собственных компонент - визуальных объектов, мастеров, библиотек функций.

Построение типичного отчета включает в себя следующие этапы:

1. Выборка данных

на основе которых строится отчет. Большинство отчетов, как правило, основано на данных из БД. Для доступа к таким данным Delphi предоставляет эффективные механизмы, компоненты- наследники TDataSet., которые и используются в FastReport. Это могут быть компоненты TTable и TQuery, которые используемые как источники данных для отчета. Организация доступа к данным из БД осуществляется ядром FastReport без участия программиста.

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

Реализация доступа к данным примерно одинакова во всех генераторах отчетов. Все генераторы умеют обращаться с компонентами доступа к данным, расположенными на формах проекта. Кроме доступа к данным, определенным в проекте, и FastReport, и ReportBuilder, и QR+QRDesigner позволяют создавать новые компоненты в run-time. В FastReport принципы создания компонентов доступа к данным максимально приближены к тем, что используются в среде Delphi. Так же, как и в Delphi, на форму кладется компонент и в инспекторе объектов настраиваются его свойства. Компонентная идеология весьма гибкая: можно легко создавать новые компоненты для поддержки разных движков доступа к данным. На самом деле сейчас у FR уже есть компоненты для доступа практически ко всем популярным СУБД.

База данных Библиотека Delphi Библиотека для FastReport
Adaptive Server Anywhere (4.x - 8.x) NativeDB frASAComponent
InterBase и его клоны FIBSIBXIBO frFIBComponentsfrIBXComponentsfrIBOComponentsfrIB_Components
Все базы которые имеют драйвера OLE-DB. ADO ADONISADO in Delphi frADNComponentsfrADOComponents
Dbf Advantage frADSComponents
Access DAO frDAOComponents
DBISAM DBISAM frDBIComponents
Oracle 8 NC OCI8 Library frOCIComponents
TurboPower's FlashFiler FlashFiler frFFComponents
Centura SQLBase Server 6(+),Oracle Server 7.2(+) with SQL*Net 2.2(+), IBM DB2 Database, Interbase Server, Microsoft SQL Server 6.5, MySQL 3.23, PostgreSQL 7.1, Sybase ASE и ASA, Informix. Все базы данных которые имеют ODBC драйвера. SQLDirect frSDComponents
Все базы которые поддерживает BDE. BDE frBDEComponents
Все базы для которых есть DBX драйвера. DBX frDBXComponents

2. Ввод параметров

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

Этот этап реализован в разных генераторах отчетов по-разному. Так, в ReportBuilderб Rave и QR+QRDesigner есть возможность запроса параметров, если отчет использует данные из запроса (Query). Для диалога с пользователем используется "штатное" диалоговое окно. Кроме того, для запроса параметров можно использовать форму, разработанную в среде Delphi. Правда, при необходимости каких-либо изменений в логике работы придется перекомпилировать проект.

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

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

Пример 1 - после формирования третьей страницы отчет может вывести диалог с запросом - а надо ли строить остальные страницы?

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

3. Построение отчетной формы

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

Для построения формы отчета в FastReport используется визуальная среда разработки - дизайнер отчетов. Интерфейс дизайнера подобен большинству современных приложений, работающих с документами. Расположение традиционных панелей инструментов (toolbars), можно изменять по своему вкусу. Для удобства манипуляции свойствами объектов отчета используется инспектор объектов, аналогичный встроенному в среду разработки Borland Delphi.

4. Обработка данных

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

Реализовать подобную обработку можно, прибегнув к написанию обработчиков событий в Delphi - именно так и сделано во всех генераторах отчетов. Но этот способ не дает достаточной гибкости отчету, поскольку не позволяет создавать новые отчеты вне среды Delphi без переписывания и перекомпиляции проекта. Для достижения таковой универсальности в FastReport и ReportBuilder применен встроенный язык - упрощенный аналог Pascal. Скрипты, написанные на этом языке, по сути дела, являются обработчиками событий, вызывающимися перед прорисовкой объектов. Это дает возможность выполнять достаточно сложную обработку информации без написания кода в Delphi, и, соответственно, без жесткой привязки отчета к проекту.

Возможности встроенного языка FastReport довольно широки. Из скрипта доступны все свойства и методы объектов отчета, а также переменные, поля таблиц БД. В скрипте можно создавать переменные и массивы, которые будут доступны во всем отчете. О возможностях встроенного языка говорит тот факт, что такая довольно сложная задача, как печать сумм группы в ее заголовке (сама сумма считается в подвале группы) средствами языка FastReport делается элементарно.

5. Готовый отчет

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

Кроме того, ни один из существующих сегодня генераторов отчетов не поддерживает такое число сред разработки (Можно сказать, что мы заглядываем в рот Borland и стараемся выпустить генератор отчетов под любую новую версию их сред разработки :-) ). Итак, FastReport сегодня можно использовать в средах: Delphi со второй по 7ю версию, C++Builder всех версий, а также в первой визуальной среде разработки приложений под Linux - Kylix всех версий. Можем похвастаться, что это наша компания выпустила первый генератор отчетов для Kylix, Rave, который сейчас поставляется с новыми версиями продуктов Borland, в том числе и Kylix3, был выпущен примерно на полгода позже. :-)

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

Что же еще новенького планируется?

  • Формат сохранения файлов - текстовый и бинарный dfm, а также XML
  • Новый объект - диагональная линия.
  • Новые типы заливки для объектов.
  • Текст под углом 0..360.
  • Отступ параграфа.
  • Возможность отключения печати объектов отчета.
  • Наследование форм отчетов.
  • Возможность отключить редакторы св-в и компонентов, если дизайнер не используется.
Скрипт
  • Единый скрипт для всего отчета (как unit в Delphi).
  • Поддержка синтаксиса как Pascal, так и C++ в скриптовом языке
  • Новые обработчики событий для объектов отчета.
  • Новые возможности (try/except, with, case и т.п.)
  • Увеличенная (в сравнении с FR2.4) скорость работы.
Дизайнер:
  • Архитектура - компактное независимое ядро + интерфейс.
  • Улучшенный интерфейс, возможность докинга вспомогательных окон.
  • Улучшенный Инспектор объектов
  • Масштабирование (Zoom).
  • Редактирование мемо-объектов на месте.
  • Более удобное рисование линий.
  • Более удобная вставка бэндов.
  • Бэнды, "прилипающие" друг к другу.
  • Более удобный выбор поля БД для мемо-объекта.
  • Возможность отображать содержимое поля БД вместо его названия.
  • Сетка-миллиметровка, дюймовка, с произвольным шагом.
  • Возможность построения отчетов для вывода на матричный принтер.
  • Изменение левой/правой границ листа (объекты сдвигаются автоматически).
  • Мастера для создания базовых типов отчетов.
  • Копирование объектов в буфер обмена Windows.
  • Полный откат / возврат (Undo/Redo).
Глобальный словарь данных:
  • Задание имен (алиасов) для всех таблиц и полей, содержащихся в БД проекта.
  • Автоматическая подстановка алиасов во всех диалоговых окнах FR.
Предварительный просмотрщик:
  • Улучшенный интерфейс.
  • Редактирование на месте.
  • События, генерируемые на сформированном отчете могут быть обработаны в скрипте.
  • Выделение объектов и копирование в буфер обмена.
Дополнительные объекты:
  • Добавить свой объект проще, чем когда бы то ни было.

Некоторое сравнение FR 3 с существующими версиями:

Возможности FastReport 3 FastReport VCL FastReport CLX
Скриптовый язык advanced + +
Подсветка синтаксиса в редакторе скрипта + + +
Смена band datasource из скрипта + + +
Доступ из скрипта к объектам на других страницах отчета + + +
Функция FORMATTEXT, оператор FOR, процедуры EXIT, INC и DEC в FastReport Pascal and more + +
Поддержка Interbase Express (IBX), IBObjects, ActiveX Data Objects (ADO) advanced and easy support more dbs support more dbs
Delphi6 dbExpress DBXComponents + + +
Object Inspector full advanced advanced
Cross-tab отчеты advanced advanced basic (yet)
Диалоги + + +
Line style + + +
BarCode + + +
RTF 2.0 + + +
Компонент TfrPreview для создания собственного предварительного просмотра + + +
Компонент TfrPrintTable + + +
Опции для объекта "Text": толщина линий и символов, top and left gaps, "Скрывать повторяющиеся значения" + + +
Restrict object editing, moving, resizing, deleting + + +
Option for bands: PrintChildIfInvisible + + +
Свойство GroupHeader band: Master + + +
Словарь данных + + +
Свйство BandAlign для всех объектов отчета + + +
Свойство объекта Text: HideZeros (скрывать нулевые) + + +
TfrReport.OnObjectClick event + + +
Свойство TfrReport.MDIPreview + + +
Свойство TfrReport.PrintIfEmpty TfrDesigner.OpenDir, SaveDir + + +
Свойство TfrPage.Visible + + +
Фильтры экспорта xml, txt, etc txt, htm, csv, rtf, xls,etc txt, htm, csv, rtf, xls,etc
Языки 21 21 21
Локализация инспектора + + +
Поддержка нескольких языков одновременно + + Нет
Поддержка языков "справа-налево" + + +



Быстрое копирование файла

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


 procedure CopyFile(Source, Dest: string);
 var
   SrcFile: Integer;
   DestFile: Integer;
   S: string;
   RetCode: Longint;
   OpenFileBuf: TOFStruct;
   FName: array[0..255] of Char;
 begin
   StrPCopy(FName, Source);
   SrcFile := LZOpenFile(FName, OpenFileBuf, of_Read);
   StrPCopy(FName, Dest);
   DestFile := LZOpenFile(FName, OpenFileBuf, of_Create);
 
   RetCode := LZCopy(SrcFile, DestFile);
   if RetCode >= 0 then
   begin
     LZClose(SrcFile);
     LZClose(DestFile);
   end
   else
   begin
     Str(RetCode, S);
     MessageDlg('Не могу скопировать ' + Source + ' в ' +
       Dest + #13 + 'Код ошибки = ' + S, mtError, [mbOk], 0);
   end;
 end;
 




Быстрое копирование с диска на дискету и обратно

Фармацевтика - наука о форматировании диска C.

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

Пример процедуры копирования файла copyfile:


 function CopyFile(FromPath, ToPath: string): integer;
 var
   F1: file;
   F2: file;
   NumRead: word;
   NumWritten: word;
   Buf: pointer;
   BufSize: longint;
   Totalbytes: longint;
   TotalRead: longint;
 begin
   Result := 0;
   Assignfile(f1, FromPath);
   Assignfile(F2, ToPath);
   reset(F1, 1);
   TotalBytes := Filesize(F1);
   Rewrite(F2, 1);
   BufSize := 16384;
   GetMem(buf, BufSize);
   TotalRead := 0;
   repeat
     BlockRead(F1, Buf^, BufSize, NumRead);
     inc(TotalRead, NumRead);
     BlockWrite(F2, Buf^, NumRead, NumWritten);
   until (NumRead = 0) or (NumWritten <> NumRead);
   if (NumWritten <> NumRead) then
   begin
     {ошибка }
     result := -1;
   end;
   Closefile(f1);
   Closefile(f2);
 end;
 

Если у вас есть file of byte (бинарный файл), или просто File, вы должны использовать Blockread, который позволяет устанавливать размер буфера, равный 64Кб. Ниже я предоставляю вашему вниманию "быстрый" способ достижения цели. Воспользуйтесь Compress (который, я надеюсь, вы найдете в поставке Delphi, в противном случае обратитесь на сайт Microsoft), который позволит вам создавать файлы типа filename.ex_. Это означает, что для копирования информации требуется гораздо меньше усилий.

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


 function TInstallForm.UnCompress(src, dest: string; var Error: LongInt):
   Boolean;
 var
   s, d: TOFStruct;
   fs, fd: Integer;
   fnSrc, fnDest: PChar;
 begin
   src := src + #0;
   dest := dest + #0;
   fnSrc := @src[1]; { Хитро преобразуем строки в ASCIIZ }
   fnDest := @dest[1];
 
   fs := LZOpenFile(fnSrc, s, OF_READ); { Получаем дескриптор файла }
   fd := LZOpenFile(fnDest, d, OF_CREATE);
 
   Error := LZCopy(fs, fd); { Вот магический вызов API }
   Result := (Error > -1);
 
   LZClose(fs); { Убедитесь, что закрыли! }
   LZClose(fd);
 end;
 
 procedure UnCompressError(Error: LongInt);
 begin
   case Error of
     LZERROR_BADINHANDLE: S := 'Неверный дескриптор
       исходного файла';
         LZERROR_BADOUTHANDLE: S := 'Неверный дескриптор
       целевого файла';
         LZERROR_BADVALUE: S := 'Входной параметр вышел за
       границы диапазона';
         LZERROR_GLOBALLOC: S := 'Недостаточно памяти
       для требуемого буфера';
         LZERROR_GLOBLOCK: S := 'Неверный дескриптор
       структуры внутренних данных';
         LZERROR_READ: S := 'Неверный формат исходного файла';
     LZERROR_UNKNOWNALG: S := 'Исходный файл был упакован
       с использованием неизвестного алгоритма сжатия';
         LZERROR_WRITE: S := 'Недостаточно места для выходного файла'
   else
     S := 'Неизвестная проблема с распаковкой'
   end;
   MessageDlg(S, mtConfirmation, [mbOK], 0);
   Close
 end;
 


 function CopyFile(SrcName, DestName: string): boolean;
 { базовый метод копирования файла; требует
 полный путь & имя для исходного & целевого файла }
 var
   Buf: array[1..1024 * 4] of byte;
   { этот размер может быть изменен..
   объявляя указатель, вы можете использовать GetMem
   для создания в куче большого буфера }
 
   TotalRead: longint;
   NumRead,
     NumWritten: word;
   TotalWritten: longint;
   FromFileSize: longint;
   FrF, ToF: file;
   FileTime: longint;
 begin
   FGetTime(SrcName, FileTime);
   Assign(FrF, SrcName);
   Reset(FrF, 1);
   FromFileSize := FileSize(FrF);
 
   Assign(ToF, DestName);
   Rewrite(ToF, 1);
   TotalRead := 0;
   TotalWritten := 0;
   repeat
     BlockRead(FrF, Buf, SizeOf(Buf), NumRead);
     TotalRead := TotalRead + NumRead;
 
     BlockWrite(ToF, Buf, NumRead, NumWritten);
     TotalWritten := TotalWritten + NumWritten;
   until (NumRead = 0) or (NumWritten <> NumRead);
   Close(FrF);
   Close(ToF);
   { возвращаем true, если они равны, в противном случае возвращаем false }
   CopyFile := (TotalWritten = FromFileSize);
 end;
 




Как быстро выводить графику (a то Canvas очень медленно работает)

Вот пример заполнения формы точками случайного цвета:


 type
   TRGB = record
     b, g, r: byte;
   end;
   ARGB = array[0..1] of TRGB;
   PARGB = ^ARGB;
 
 var
   b: TBitMap;
 
 procedure TForm1.FormCreate(sender: TObject);
 begin
   b := TBitMap.Create;
   b.pixelformat := pf24bit;
   b.width := Clientwidth;
   b.height := Clientheight;
 end;
 
 procedure TForm1.Tim1OnTimer(sender: TObject);
 var
   p: PARGB;
   x, y: integer;
 begin
   for y := 0 to b.height - 1 do
   begin
     p := b.scanline[y];
     for x := 0 to b.width - 1 do
     begin
       p[x].r := random(256);
       p[x].g := random(256);
       p[x].b := random(256);
     end;
   end;
   canvas.draw(0, 0, b);
 end;
 
 procedure TForm1.FormDestroy(sender: TObject);
 begin
   b.free;
 end;
 




Процедуры быстрого получения размера изображения из файлов JPG, GIF, PNG



 unit ImgSize;
 
 interface
 
 uses
   Classes;
 
 procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
 procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
 procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
 
 implementation
 
 uses
   SysUtils;
 
 function ReadMWord(f: TFileStream): word;
   type TMotorolaWord = record
   case byte of
     0: (Value: word);
     1: (Byte1, Byte2: byte);
   end;
 var
   MW: TMotorolaWord;
 begin
   { It would probably be better to just read these two bytes in normally }
   { and then do a small ASM routine to swap them. But we aren't talking }
   { about reading entire files, so I doubt the performance gain would be }
   { worth the trouble.}
   f.read(MW.Byte2, SizeOf(Byte));
   f.read(MW.Byte1, SizeOf(Byte));
   Result := MW.Value;
 end;
 
 procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
 const
   ValidSig : array[0..1] of byte = ($FF, $D8);
   Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
 var
   Sig: array[0..1] of byte;
   f: TFileStream;
   x: integer;
   Seg: byte;
   Dummy: array[0..15] of byte;
   Len: word;
   ReadLen: LongInt;
 begin
   FillChar(Sig, SizeOf(Sig), #0);
   f := TFileStream.Create(sFile, fmOpenRead);
   try
     ReadLen := f.read(Sig[0], SizeOf(Sig));
     for x := Low(Sig) to High(Sig) do
       if Sig[x] <> ValidSig[x] then
         ReadLen := 0;
     if ReadLen > 0 then
     begin
       ReadLen := f.read(Seg, 1);
       while (Seg = $FF) and (ReadLen > 0) do
       begin
         ReadLen := f.read(Seg, 1);
         if Seg <> $FF then
         begin
           if (Seg = $C0) or (Seg = $C1) then
           begin
             ReadLen := f.read(Dummy[0], 3);
             { don't need these bytes }
             wHeight := ReadMWord(f);
             wWidth := ReadMWord(f);
           end
           else
           begin
             if not (Seg in Parameterless) then
             begin
               Len := ReadMWord(f);
               f.Seek(Len-2, 1);
               f.read(Seg, 1);
             end
             else
               Seg := $FF;
             { Fake it to keep looping. }
           end;
         end;
       end;
     end;
   finally
     f.Free;
   end;
 end;
 
 procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
 type TPNGSig = array[0..7] of byte;
 const
   ValidSig: TPNGSig = (137,80,78,71,13,10,26,10);
 var
   Sig: TPNGSig;
   f: tFileStream;
   x: integer;
 begin
   FillChar(Sig, SizeOf(Sig), #0);
   f := TFileStream.Create(sFile, fmOpenRead);
   try
     f.read(Sig[0], SizeOf(Sig));
     for x := Low(Sig) to High(Sig) do
       if Sig[x] <> ValidSig[x] then
         exit;
     f.Seek(18, 0);
     wWidth := ReadMWord(f);
     f.Seek(22, 0);
     wHeight := ReadMWord(f);
   finally
     f.Free;
   end;
 end;
 
 procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
 type
   TGIFHeader = record
     Sig: array[0..5] of char;
     ScreenWidth, ScreenHeight: word;
     Flags, Background, Aspect: byte;
   end;
   TGIFImageBlock    = record
     Left, Top, Width, Height: word;
     Flags: byte;
   end;
 var
   f: file;
   Header: TGifHeader;
   ImageBlock: TGifImageBlock;
   nResult: integer;
   x: integer;
   c: char;
   DimensionsFound: boolean;
 begin
   wWidth := 0;
   wHeight := 0;
   if sGifFile = '' then
     exit;
   {$I-}
   FileMode := 0; { read-only }
   AssignFile(f, sGifFile);
   reset(f, 1);
   if IOResult <> 0 then {Could not open file }
     exit; { Read header and ensure valid file. }
   BlockRead(f, Header, SizeOf(TGifHeader), nResult);
   if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0)
   or (StrLComp('GIF', Header.Sig, 3) <> 0) then
   begin { Image file invalid }
     close(f);
     exit;
   end; { Skip color map, if there is one }
   if (Header.Flags and $80) > 0 then
   begin
     x := 3 * (1 shl ((Header.Flags and 7) + 1));
     Seek(f, x);
     if IOResult <> 0 then
     begin { Color map thrashed }
       close(f);
       exit;
     end;
   end;
   DimensionsFound := False;
   FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
   { Step through blocks. }
   BlockRead(f, c, 1, nResult);
   while (not EOF(f)) and (not DimensionsFound) do
   begin
     case c of
       ',': { Found image }
       begin
         BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
         if nResult <> SizeOf(TGIFImageBlock) then
         begin { Invalid image block encountered }
           close(f);
           exit;
         end;
         wWidth := ImageBlock.Width;
         wHeight := ImageBlock.Height;
         DimensionsFound := True;
       end;
       'y' : { Skip }
       begin
         { NOP }
       end;
       { nothing else. just ignore }
     end;
     BlockRead(f, c, 1, nResult);
   end;
   close(f);
   {$I+}
 end;
 
 end.
 




Убыстрить открытие таблицы Paradox

Автор: Rich Jones

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




Ускорение работы TreeView

Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).

Для сравнения:

TreeView:

128 сек. для загрузки 1000 элементов (без сортировки)*
270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

HETreeView:

1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!! (2.3 секунды без сортировки = stText)*
0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!

Примечание:

  • Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.
  • Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

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


 unit HETreeView;
 {$R-}
 
 // Описание: Реактивный TreeView
 (*
 
 TREEVIEW:
 128 сек. для загрузки 1000 элементов (без сортировки)*
 270 сек. для сохранения 1000 элементов (4.5 минуты!!!)
 
 HETREEVIEW:
 1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!!
   (2.3 секунды без сортировки = stText)*
 0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!
 
 NOTES:
 - Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.
 
 - * Если TTreeView пуст, загрузка происходит за 1.5 секунды,
 плюс 1.5 секунды на стирание 1000 элементов
   (общее время загрузки составило 3 секунды).
 В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд.
 Очистка компонента осуществлялась вызовом функции
 SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).
 *)
 
 interface
 
 uses
 
   SysUtils, Windows, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, ComCtrls, CommCtrl;
 
 type
 
   THETreeView = class(TTreeView)
   private
     FSortType: TSortType;
     procedure SetSortType(Value: TSortType);
   protected
     function GetItemText(ANode: TTreeNode): string;
   public
     constructor Create(AOwner: TComponent); override;
     function AlphaSort: Boolean;
     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
     procedure LoadFromFile(const AFileName: string);
     procedure SaveToFile(const AFileName: string);
     procedure GetItemList(AList: TStrings);
     procedure SetItemList(AList: TStrings);
     //Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но...
     function IsItemBold(ANode: TTreeNode): Boolean;
     procedure SetItemBold(ANode: TTreeNode; Value: Boolean);
   published
     property SortType: TSortType read FSortType write SetSortType default
       stNone;
   end;
 
 procedure Register;
 
 implementation
 
 function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer;
   stdcall;
 begin
 
   {with Node1 do
   if Assigned(TreeView.OnCompare) then
   TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result)
   else}
   Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
 end;
 
 constructor THETreeView.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   FSortType := stNone;
 end;
 
 procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean);
 var
 
   Item: TTVItem;
   Template: Integer;
 begin
 
   if ANode = nil then
     Exit;
 
   if Value then
     Template := -1
   else
     Template := 0;
   with Item do
   begin
     mask := TVIF_STATE;
     hItem := ANode.ItemId;
     stateMask := TVIS_BOLD;
     state := stateMask and Template;
   end;
   TreeView_SetItem(Handle, Item);
 end;
 
 function THETreeView.IsItemBold(ANode: TTreeNode): Boolean;
 var
 
   Item: TTVItem;
 begin
 
   Result := False;
   if ANode = nil then
     Exit;
 
   with Item do
   begin
     mask := TVIF_STATE;
     hItem := ANode.ItemId;
     if TreeView_GetItem(Handle, Item) then
       Result := (state and TVIS_BOLD) <> 0;
   end;
 end;
 
 procedure THETreeView.SetSortType(Value: TSortType);
 begin
 
   if SortType <> Value then
   begin
     FSortType := Value;
     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
       (SortType in [stText, stBoth]) then
       AlphaSort;
   end;
 end;
 
 procedure THETreeView.LoadFromFile(const AFileName: string);
 var
 
   AList: TStringList;
 begin
 
   AList := TStringList.Create;
   Items.BeginUpdate;
   try
     AList.LoadFromFile(AFileName);
     SetItemList(AList);
   finally
     Items.EndUpdate;
     AList.Free;
   end;
 end;
 
 procedure THETreeView.SaveToFile(const AFileName: string);
 var
 
   AList: TStringList;
 begin
 
   AList := TStringList.Create;
   try
     GetItemList(AList);
     AList.SaveToFile(AFileName);
   finally
     AList.Free;
   end;
 end;
 
 procedure THETreeView.SetItemList(AList: TStrings);
 var
 
   ALevel, AOldLevel, i, Cnt: Integer;
   S: string;
   ANewStr: string;
   AParentNode: TTreeNode;
   TmpSort: TSortType;
 
   function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar;
   begin
     ALevel := 0;
     while Buffer^ in [' ', #9] do
     begin
       Inc(Buffer);
       Inc(ALevel);
     end;
     Result := Buffer;
   end;
 
 begin
 
   // Удаление всех элементов - в обычной ситуации
   // подошло бы Items.Clear, но уж очень медленно
   SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT));
   AOldLevel := 0;
   AParentNode := nil;
 
   //Снятие флага сортировки
   TmpSort := SortType;
   SortType := stNone;
   try
     for Cnt := 0 to AList.Count - 1 do
     begin
       S := AList[Cnt];
       if (Length(S) = 1) and (S[1] = Chr($1A)) then
         Break;
 
       ANewStr := GetBufStart(PChar(S), ALevel);
       if (ALevel > AOldLevel) or (AParentNode = nil) then
       begin
         if ALevel - AOldLevel > 1 then
           raise Exception.Create('Неверный уровень TreeNode');
       end
       else
       begin
         for i := AOldLevel downto ALevel do
         begin
           AParentNode := AParentNode.Parent;
           if (AParentNode = nil) and (i - ALevel > 0) then
             raise Exception.Create('Неверный уровень TreeNode');
         end;
       end;
       AParentNode := Items.AddChild(AParentNode, ANewStr);
       AOldLevel := ALevel;
     end;
   finally
     //Возвращаем исходный флаг сортировки...
     SortType := TmpSort;
   end;
 end;
 
 procedure THETreeView.GetItemList(AList: TStrings);
 var
 
   i, Cnt: integer;
   ANode: TTreeNode;
 begin
 
   AList.Clear;
   Cnt := Items.Count - 1;
   ANode := Items.GetFirstNode;
   for i := 0 to Cnt do
   begin
     AList.Add(GetItemText(ANode));
     ANode := ANode.GetNext;
   end;
 end;
 
 function THETreeView.GetItemText(ANode: TTreeNode): string;
 begin
 
   Result := StringOfChar(' ', ANode.Level) + ANode.Text;
 end;
 
 function THETreeView.AlphaSort: Boolean;
 var
 
   I: Integer;
 begin
 
   if HandleAllocated then
   begin
     Result := CustomSort(nil, 0);
   end
   else
     Result := False;
 end;
 
 function THETreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
 var
 
   SortCB: TTVSortCB;
   I: Integer;
   Node: TTreeNode;
 begin
 
   Result := False;
   if HandleAllocated then
   begin
     with SortCB do
     begin
       if not Assigned(SortProc) then
         lpfnCompare := @DefaultTreeViewSort
       else
         lpfnCompare := SortProc;
       hParent := TVI_ROOT;
       lParam := Data;
       Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
     end;
 
     if Items.Count > 0 then
     begin
       Node := Items.GetFirstNode;
       while Node <> nil do
       begin
         if Node.HasChildren then
           Node.CustomSort(SortProc, Data);
         Node := Node.GetNext;
       end;
     end;
   end;
 end;
 
 //Регистрация компонента
 
 procedure Register;
 begin
 
   RegisterComponents('Win95', [THETreeView]);
 end;
 
 end.
 




Ускорение работы TreeView 2


 Try
 
 LockWindowUpdate(TreeView1.Handle);
 ...
 finally
 
 LockWindowUpdate(0);
 

Выключите свойство сортировки (установите sort в off).

Я много работаю с TTreeView. За раз обычно я манипулирую сотнями, а то и тысячами узлов. Для сокращения времени обработки воспользуйтесь моим опытом и советами:

  • Используйте TreeView1.BeginUpdate и TreeView1.EndUpdate перед и после того, как делаете много изменений и добавлений.
  • Установите SortType на stNone по умолчанию. (Запрещаем дереву делать автоматическую сортировку при каждом добавлении или изменении узлов. Это, вероятно, будет самой большой экономией временных затрат.)

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


 procedure TForm1.TreeView1Expanded(Sender: TObject; Node: TTreeNode);
 begin
   Node.Alphasort;  {Сортируем дочерние узлы и -только- дочерние узлы}
 end;
 

Данный код позаботится о сортировки каждого уровня, кроме корневого. Я не знаю способа сообщить TTreeView о необходимости сортировки только корневых узлов. TreeView1.Alphasort сортирует -каждый- элемент дерева (тратится много времени). Если вам нужно сортировать элементы корневого уровня, не сортируя все узлы дерева, вы должны делать это сами. Вероятно, необходимо начать с QuickSort или InsertionSort, и метода TTreeNode.MoveTo.

Поместите ваш код для работы с TreeView между вызовами TreeView1.Items.BeginUpdate и TreeView1.Items.EndUpdate. И убедитесь в том, что дерево неотсортировано.




Быстрая обработка файла

Автор: Mike Scott

Хакеp пpиходит к специалистy по паpоноpмальным явлениям:
- Доктоp, помогите мне! У меня дома такое твоpиться! Диски по комнате летают, сами в компьютеp ставяться и Windows yстанавливают!
- У-y! Батенька, да y вас полтеpГейтс!


 type
   TByteSet = set of byte;
 
 procedure ProcessFile(const InFileName, OutFileName:
   string; Valid: TByteSet);
 var
   InFile, OutFile: file;
   InBuf, OutBuf: PByteArray;
   InPos, OutPos: word;
   BytesRead: word;
 begin
   OutBuf := nil;
   New(InBuf);
   try
     New(OutBuf);
     AssignFile(InFile, InFileName);
     AssignFile(OutFile, OutFileName);
     Reset(InFile, 1);
     Rewrite(OutFile, 1);
     repeat
       Blockread(InFile, InBuf^, SizeOf(InBuf^), BytesRead);
       OutPos := 0;
       for InPos := 0 to BytesRead - 1 do
       begin
         if InBuf^[InPos] in Valid then
         begin
           inc(OutPos);
         end;
       end;
       if OutPos > 0 then
         BlockWrite(OutFile, OutBuf^, OutPos);
     until BytesRead <> SizeOf(InBuf^);
     CloseFile(InFile);
     CloseFile(OutFile);
   finally
     if OutBuf <> nil then
       Dispose(OutBuf);
     Dispose(InBuf);
   end;
 end;
 

Применять это можно приблизительно так:


 ProcessFile( 'SOURCE.RAW', 'NEW.RAW', [ 10, 13, 32..255 ] ) ;
 




FFT аглоритм для Delphi

Привожу FFT-алгоритм, позволяющий оперировать 256 точками данных примерно за 0.008 секунд на P66 (с 72MB, YMMV). Создан на Delphi.

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

Но я не думаю что алгоритм слишком плох, в нем заложено немало математических трюков. Имеется некоторое количество рекурсий, но они занимается не копированием данных, а манипуляциями с указателями, если у нас есть массив размером N = 2^d, то глубина рекурсии составит всего d. Возможно имело бы смысл применить развертывающуюся рекурсию, но не пока не ясно, поможет ли ее применение в данном алгоритме. (Но вероятно мы смогли бы достаточно легко получить надежную математическую модель, развертывая в рекурсии один или два нижних слоя, то есть проще говоря:


 if Depth < 2 then
   {производим какие-либо действия}
 

вместо текущего 'if Depth = 0 then...' Это должно устранить непродуктивные вызовы функций, что несомненно хорошо в то время, пока развертывающая рекурсия работает с ресурсами.)

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

Вероятно в машине с большим объемом оперативной памяти следует использовать VirtualAlloc(... PAGE_NOCACHE) для Src, Dest и таблиц поиска.

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

Что делает данная технология вкратце. Имеется несколько FFT, образующих 'комплексный FT', который понимает и о котором заботится моя технология. Это означает, что если N = 2^d, Src^ и Dest^ образуют массив из N TComplexes, происходит вызов


 FFT(d, Src, Dest)
 

, далее заполняем Dest с применением 'комплексного FT' после того, как результат вызова Dest^[j] будет равен


 1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])
 

, где EiT(t) = cos(t) + i sin(t) . То есть, стандартное преобразование Фурье.

Публикую две версии: в первой версии я использую TComplex с функциями для работы с комплексными числами. Во второй версии все числа реальные - вместо массивов Src и Dest мы используем массивы реальных чисел SrcR, SrcI, DestR, DestI (в блоке вычислений реальных чисел), и вызовы всех функций осуществляются линейно. Первая версия достаточна легка в реализации, зато вторая - значительно быстрее. (Обе версии оперируют 'комплексными FFT'.) Технология работы была опробована на алгоритме Plancherel (также известным как Parseval). Обе версии работоспособны, btw: если это не работает у вас - значит я что-то выбросил вместе со своими глупыми коментариями :-) Итак, сложная версия:


 unit cplx;
 
 interface
 
 type
 
   PReal = ^TReal;
   TReal = extended;
 
   PComplex = ^TComplex;
   TComplex = record
     r: TReal;
     i: TReal;
   end;
 
 function MakeComplex(x, y: TReal): TComplex;
 function Sum(x, y: TComplex): TComplex;
 function Difference(x, y: TComplex): TComplex;
 function Product(x, y: TComplex): TComplex;
 function TimesReal(x: TComplex; y: TReal): TComplex;
 function PlusReal(x: TComplex; y: TReal): TComplex;
 function EiT(t: TReal): TComplex;
 function ComplexToStr(x: TComplex): string;
 function AbsSquared(x: TComplex): TReal;
 
 implementation
 
 uses SysUtils;
 
 function MakeComplex(x, y: TReal): TComplex;
 begin
 
   with result do
   begin
     r := x;
     i := y;
   end;
 end;
 
 function Sum(x, y: TComplex): TComplex;
 begin
   with result do
   begin
 
     r := x.r + y.r;
     i := x.i + y.i;
   end;
 end;
 
 function Difference(x, y: TComplex): TComplex;
 begin
   with result do
   begin
 
     r := x.r - y.r;
     i := x.i - y.i;
   end;
 end;
 
 function EiT(t: TReal): TComplex;
 begin
   with result do
   begin
 
     r := cos(t);
     i := sin(t);
   end;
 end;
 
 function Product(x, y: TComplex): TComplex;
 begin
   with result do
   begin
 
     r := x.r * y.r - x.i * y.i;
     i := x.r * y.i + x.i * y.r;
   end;
 end;
 
 function TimesReal(x: TComplex; y: TReal): TComplex;
 begin
   with result do
   begin
 
     r := x.r * y;
     i := x.i * y;
   end;
 end;
 
 function PlusReal(x: TComplex; y: TReal): TComplex;
 begin
   with result do
   begin
 
     r := x.r + y;
     i := x.i;
   end;
 end;
 
 function ComplexToStr(x: TComplex): string;
 begin
   result := FloatToStr(x.r)
     + ' + '
     + FloatToStr(x.i)
     + 'i';
 end;
 
 function AbsSquared(x: TComplex): TReal;
 begin
   result := x.r * x.r + x.i * x.i;
 end;
 
 end.
 


 unit cplxfft1;
 
 interface
 
 uses Cplx;
 
 type
   PScalar = ^TScalar;
   TScalar = TComplex; {Легко получаем преобразование в реальную величину}
 
   PScalars = ^TScalars;
   TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
     of TScalar;
 
 const
   TrigTableDepth: word = 0;
   TrigTable: PScalars = nil;
 
 procedure InitTrigTable(Depth: word);
 
 procedure FFT(Depth: word;
   Src: PScalars;
   Dest: PScalars);
 
 {Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение
 (integer(1) shl Depth) * SizeOf(TScalar)
 байт памяти!}
 
 implementation
 
 procedure DoFFT(Depth: word;
   Src: PScalars;
   SrcSpacing: word;
   Dest: PScalars);
 {рекурсивная часть, вызываемая при готовности FFT}
 var
   j, N: integer;
   Temp: TScalar;
   Shift: word;
 begin
   if Depth = 0 then
   begin
     Dest^[0] := Src^[0];
     exit;
   end;
 
   N := integer(1) shl (Depth - 1);
 
   DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);
   DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N]);
 
   Shift := TrigTableDepth - Depth;
 
   for j := 0 to N - 1 do
   begin
     Temp := Product(TrigTable^[j shl Shift],
       Dest^[j + N]);
     Dest^[j + N] := Difference(Dest^[j], Temp);
     Dest^[j] := Sum(Dest^[j], Temp);
   end;
 end;
 
 procedure FFT(Depth: word;
   Src: PScalars;
   Dest: PScalars);
 var
   j, N: integer;
   Normalizer: extended;
 begin
   N := integer(1) shl depth;
   if Depth TrigTableDepth then
     InitTrigTable(Depth);
   DoFFT(Depth, Src, 1, Dest);
   Normalizer := 1 / sqrt(N);
   for j := 0 to N - 1 do
     Dest^[j] := TimesReal(Dest^[j], Normalizer);
 end;
 
 procedure InitTrigTable(Depth: word);
 var
   j, N: integer;
 begin
   N := integer(1) shl depth;
   ReAllocMem(TrigTable, N * SizeOf(TScalar));
   for j := 0 to N - 1 do
 
     TrigTable^[j] := EiT(-(2 * Pi) * j / N);
   TrigTableDepth := Depth;
 end;
 
 initialization
   ;
 
 finalization
   ReAllocMem(TrigTable, 0);
 
 end.
 


 unit DemoForm;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Memo1: TMemo;
     Edit1: TEdit;
     Label1: TLabel;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses cplx, cplxfft1, MMSystem;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   j: integer;
   s: string;
 
   src, dest: PScalars;
   norm: extended;
   d, N, count: integer;
   st, et: longint;
 begin
 
   d := StrToIntDef(edit1.text, -1);
   if d < 1 then
     raise
       exception.Create('глубина рекурсии должны быть положительным целым числом');
 
   N := integer(1) shl d;
 
   GetMem(Src, N * Sizeof(TScalar));
   GetMem(Dest, N * SizeOf(TScalar));
 
   for j := 0 to N - 1 do
   begin
     src^[j] := MakeComplex(random, random);
   end;
 
   begin
 
     st := timeGetTime;
     FFT(d, Src, dest);
     et := timeGetTime;
 
   end;
 
   Memo1.Lines.Add('N = ' + IntToStr(N));
   Memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));
 
   norm := 0;
   for j := 0 to N - 1 do
     norm := norm + AbsSquared(src^[j]);
   Memo1.Lines.Add('Норма данных: ' + #9 + FloatToStr(norm));
   norm := 0;
   for j := 0 to N - 1 do
     norm := norm + AbsSquared(dest^[j]);
   Memo1.Lines.Add('Норма FT: ' + #9#9 + FloatToStr(norm));
 
   Memo1.Lines.Add('Время расчета FFT: ' + #9
     + inttostr(et - st)
     + ' мс.');
   Memo1.Lines.Add(' ');
 
   FreeMem(Src);
   FreeMem(DEst);
 end;
 
 end.
 

**** Версия для работы с реальными числами:


 unit cplxfft2;
 
 interface
 
 type
 
   PScalar = ^TScalar;
   TScalar = extended;
 
   PScalars = ^TScalars;
   TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
     of TScalar;
 
 const
 
   TrigTableDepth: word = 0;
   CosTable: PScalars = nil;
   SinTable: PScalars = nil;
 
 procedure InitTrigTables(Depth: word);
 
 procedure FFT(Depth: word;
 
   SrcR, SrcI: PScalars;
   DestR, DestI: PScalars);
 
 {Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение
 
 (integer(1) shl Depth) * SizeOf(TScalar)
 
 байт памяти!}
 
 implementation
 
 procedure DoFFT(Depth: word;
 
   SrcR, SrcI: PScalars;
   SrcSpacing: word;
   DestR, DestI: PScalars);
 {рекурсивная часть, вызываемая при готовности FFT}
 var
   j, N: integer;
 
   TempR, TempI: TScalar;
   Shift: word;
   c, s: extended;
 begin
   if Depth = 0 then
 
   begin
     DestR^[0] := SrcR^[0];
     DestI^[0] := SrcI^[0];
     exit;
   end;
 
   N := integer(1) shl (Depth - 1);
 
   DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);
   DoFFT(Depth - 1,
 
     @SrcR^[srcSpacing],
     @SrcI^[SrcSpacing],
     SrcSpacing * 2,
     @DestR^[N],
     @DestI^[N]);
 
   Shift := TrigTableDepth - Depth;
 
   for j := 0 to N - 1 do
   begin
 
     c := CosTable^[j shl Shift];
     s := SinTable^[j shl Shift];
 
     TempR := c * DestR^[j + N] - s * DestI^[j + N];
     TempI := c * DestI^[j + N] + s * DestR^[j + N];
 
     DestR^[j + N] := DestR^[j] - TempR;
     DestI^[j + N] := DestI^[j] - TempI;
 
     DestR^[j] := DestR^[j] + TempR;
     DestI^[j] := DestI^[j] + TempI;
   end;
 
 end;
 
 procedure FFT(Depth: word;
 
   SrcR, SrcI: PScalars;
   DestR, DestI: PScalars);
 var
   j, N: integer;
   Normalizer: extended;
 begin
 
   N := integer(1) shl depth;
 
   if Depth TrigTableDepth then
 
     InitTrigTables(Depth);
 
   DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);
 
   Normalizer := 1 / sqrt(N);
 
   for j := 0 to N - 1 do
 
   begin
     DestR^[j] := DestR^[j] * Normalizer;
     DestI^[j] := DestI^[j] * Normalizer;
   end;
 
 end;
 
 procedure InitTrigTables(Depth: word);
 var
   j, N: integer;
 begin
 
   N := integer(1) shl depth;
   ReAllocMem(CosTable, N * SizeOf(TScalar));
   ReAllocMem(SinTable, N * SizeOf(TScalar));
   for j := 0 to N - 1 do
 
   begin
     CosTable^[j] := cos(-(2 * Pi) * j / N);
     SinTable^[j] := sin(-(2 * Pi) * j / N);
   end;
   TrigTableDepth := Depth;
 
 end;
 
 initialization
 
   ;
 
 finalization
 
   ReAllocMem(CosTable, 0);
   ReAllocMem(SinTable, 0);
 
 end.
 


 unit demofrm;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, cplxfft2, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Memo1: TMemo;
     Edit1: TEdit;
     Label1: TLabel;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses MMSystem;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   SR, SI, DR, DI: PScalars;
   j, d, N: integer;
   st, et: longint;
   norm: extended;
 begin
 
   d := StrToIntDef(edit1.text, -1);
   if d < 1 then
     raise
       exception.Create('глубина рекурсии должны быть положительным целым числом');
 
   N := integer(1) shl d;
 
   GetMem(SR, N * SizeOf(TScalar));
   GetMem(SI, N * SizeOf(TScalar));
   GetMem(DR, N * SizeOf(TScalar));
   GetMem(DI, N * SizeOf(TScalar));
 
   for j := 0 to N - 1 do
   begin
 
     SR^[j] := random;
     SI^[j] := random;
   end;
 
   st := timeGetTime;
   FFT(d, SR, SI, DR, DI);
 
   et := timeGetTime;
 
   memo1.Lines.Add('N = ' + inttostr(N));
   memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));
 
   norm := 0;
   for j := 0 to N - 1 do
 
     norm := norm + SR^[j] * SR^[j] + SI^[j] * SI^[j];
   memo1.Lines.Add('норма данных: ' + #9 + FloatToStr(norm));
 
   norm := 0;
   for j := 0 to N - 1 do
 
     norm := norm + DR^[j] * DR^[j] + DI^[j] * DI^[j];
   memo1.Lines.Add('норма FT: ' + #9#9 + FloatToStr(norm));
 
   memo1.Lines.Add('Время расчета FFT: ' + #9 + inttostr(et - st));
   memo1.Lines.add('');
   (*for j:=0 to N - 1 do
 
   Memo1.Lines.Add(FloatToStr(SR^[j])
   + ' + '
   + FloatToStr(SI^[j])
   + 'i');
 
   for j:=0 to N - 1 do
 
   Memo1.Lines.Add(FloatToStr(DR^[j])
   + ' + '
   + FloatToStr(DI^[j])
   + 'i');*)
 
   FreeMem(SR, N * SizeOf(TScalar));
   FreeMem(SI, N * SizeOf(TScalar));
   FreeMem(DR, N * SizeOf(TScalar));
   FreeMem(DI, N * SizeOf(TScalar));
 end;
 
 end.
 




Полный список полей таблицы

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

Приведенный ниже пример демонстрирует технологию полного воспроизведения доступных полей в компоненте TTable или TQuery. Программа извлекает информацию о доступных полях и отображает ее в компоненте TListBox; эта информация необходима для динамического построения потомков TField. В данном примере источником данных служит компонент TTable, но той же цели может служить и TQuery (TTable и TQuery для доступа к полям таблицы используют одно и то же свойство Fields).


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
   F: TFieldDef;
   D: string;
 begin
   Table1.Active := True;
   ListBox1.Items.Clear;
   with Table1 do
   begin
     for i := 0 to FieldDefs.Count - 1 do
     begin
       F := FieldDefs.Items[i];
       case F.DataType of
         ftUnknown: D := 'Unknown';
         ftString: D := 'String';
         ftSmallint: D := 'SmallInt';
         ftInteger: D := 'Integer';
         ftWord: D := 'Word';
         ftBoolean: D := 'Boolean';
         ftFloat: D := 'Float';
         ftCurrency: D := 'Currency';
         ftBCD: D := 'BCD';
         ftDate: D := 'Date';
         ftTime: D := 'Time';
         ftDateTime: D := 'DateTime';
         ftBytes: D := 'Bytes';
         ftVarBytes: D := '';
         ftBlob: D := 'BLOB';
         ftMemo: D := 'Memo';
         ftGraphic: D := 'Graphic';
       else
         D := '';
       end;
       ListBox1.Items.Add(F.Name + ', ' + D);
     end;
   end;
   Table1.Active := False;
 end;
 




Как по текущей ячейки получить наименование столбца


 Grid.SelectedField.FieldName
 




RTL.FileExists. Неверный результат при дате файла меньше 1980 г.

Автор: Batorov_VA

Функция FileExists в модуле Sysutils.pas дает неверный результат в случае, если дата файла некорректна. В нашем случае создавался файл с датой 1601 г, который не определялся этой функцией.

Эффект проявляется в Delphi 5,6,7.

ТИПОВЫЕ РЕШЕНИЯ

Не давать возможности создаваться таким файлам.

КОММЕНТАРИЙ:

Функция FileExists обосновывает свое решение на результате вызова функции FileAge (см. Sysutils.pas). Последняя возвращает -1 в случае, если попытка определить дату была неуспешна (основной причиной считается невозможность найти файл). Поиск в Sysutils по слову "FileAge" обнаруживает следующий комментарий:

{ FileDateToDateTime converts a DOS date-and-time value to a TDateTime value. The FileAge, FileGetDate, and FileSetDate routines operate on DOS date-and-time values, and the Time field of a TSearchRec used by the FindFirst and FindNext functions contains a DOS date-and-time value. }

который недвусмысленно дает понять, что функции, работающие с датой файла, используют DOS-формат для даты/времени. В справке по Win32API в статье о функции FileTimeToDosDateTime читаем ремарку:

The MS-DOS date format can represent only dates between 1/1/1980 and 12/31/2107; this conversion fails if the input file time is outside this range.

Последняя функция используется в FileAge для конвертирования даты/времени модификации файла в выходной формат (DOS). Естественно, именно в этом месте происходит ошибка, если дата найденного файла не вписывается в диапазон.

Понять разработчиков runtime библиотеки можно - это было сделано для обратной совместимости с Delphi 1. То есть, программа, использующая старые функции Sysutils, может быть откомпилирована в любой версии Delphi и будет одинаково работать. Кроме того, при штатном использовании даты файла она никогда не может быть меньше даты рождения компьютера, на котором он был создан/изменен. А формат DOS filetime удобен тем, что помещается целиком в 32-битный integer.

Для тех, кто использует дату файла не по назначению, в результате чего она может принимать значение 1601 г, можно посоветовать написать свою функцию FileExists, используя функции API. Для примера можно изучить ту же FileAge.




Можно ли изменить число колонок и их ширину в компоненте TFileListBox


 with TDirectoryListBox(FileListBox1) do 
 begin
   Columns := 2;
   SendMessage(Handle, LB_SETCOLUMNWIDTH,
     Canvas.TextWidth('WWWWWWWW.WWW'),0);
 end;
 




FileListBox с двумя колонками

Автор: Kurt

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


 with TDirectoryListBox(FileListBox1) do
 begin
   Columns := 2;
   SendMessage(Handle, LB_SETCOLUMNWIDTH,
   LoWord(GetTextExtent(Canvas.Handle, 'WWWWWWWW.WWW', 12)), 0);
 end;
 




Свойство FileName в невизуальном компоненте

Следующий код взят из dsgnintf.pas (иногда стоит покопаться в файлах!) для свойства TMPLayer.filename, с помощью C.Calvert..

В заголовке модуля компонента...


 TFileNameProperty = class (TStringProperty)
   public
     function getattributes: TPropertyattributes; override;
     procedure Edit; override;
 end;
 

добавьте функцию регистрации...


 RegisterPropertyEditor(Typeinfo(String),
 TMyComponent, 'Filename', TFileNameProperty);
 

и код...


 function TFileNameProperty.GetAttributes;
 begin
   Result := [paDialog];
 end;
 
 Procedure TFilenameProperty.edit;
 var
   MFileOpen: TOpenDialog;
 begin
   MFileOpen := TOpenDialog.Create(Application);
   MFileOpen.Filename := GetValue;
   MFileOpen.Filter := 'Правильный тип файлов|*.*'; (* Поместите здесь ваш собственный фильтр...*)
   MFileOpen.Options := MFileOpen.Options + [ofPathMustExist,ofFileMustExist];
   try
     if MFileOpen.Execute then
       SetValue(MFileOpen.Filename);
   finally
     MFileOpen.Free;
   end;
 end;
 




FileReaderWriter-поток

Я скомпоновал небольшой модуль, облегчающий чтение и запись в поток объектов-не-компонентов. За основу взят базовый класс (TStreamable), имеющий пустые процедуры Load и Store, перекрываемые в потомках для выполнения специфических задач, плюс некоторые расширения классов TReader и TWriter, автоматизирующие работу с системными регистрами. Вы увидите это в нижней части этого совета. Надеюсь, вы найдете это полезным.

Процедуры Load и Store класса TStreamable и его потомков содержат параметры, делающие возможным чтение и запись методами классов TReader и TWriter (смотри файл помощи Component Writer's Help). Сохраняемая сущность меняется от класса к классу, поэтому для себя вы должны решить с чем вы будете работать.

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

Если еще во время разработки приложения вы знаете, объект какого класса вы будете сохранять/загружать и все, что вам нужно сделать, это инициализировать поток, filer и экземпляр объекта (только загрузка), то для этого можно использовать метод Load/Store.

Пример: (сохранение, FKnowObject - поле в TTest)


 procedure TTest.StoreKnownObject(Filename: string);
 var
 
 S: TFileStream;
 W: TEnhWriter;
 begin
 
 S := TFileStream.Create(Filename, fmOpenWrite);
 W := TEnhWriter.Create(S, 1024);
 FKnownObject.Store(W);
 W.Free;
 S.Free;
 end;
 

(загрузка объекта, сохраненного выше, предполагает, что до этого момента был осуществлен вызов FKnowObject.Create)


 procedure TTest.LoadKnownObject(Filename: string);
 var
 
 S: TFileStream;
 R: TEnhReader;
 begin
 
 S := TFileStream.Create(Filename, fmOpenRead;
 R := TEnhReader.Create(S, 1024);
 FKnownObject.Load(R); {перезаписываем все предыдущие данные объекта}
 R.Free;
 S.Free;
 end;
 

Имея список объектов, проще всего работать с ними в цикле.

Пример: (сохранение, список TKnownObjects)


 procedure TTest.StoreKnownList(Filename: string; List: TList);
 var
 
 S: TFileStream;
 W: TEnhWriter;
 I: Integer;
 begin
 
 S := TFileStream.Create(Filename, fmOpenWrite;
 W := TEnhWriter.Create(S, 1024);
 W.WriteListBegin;
 with List do
 for I := 0 to Count -1 do
 TKnownObject(Items[I]).Store(W);
 W.WriteListEnd;
 W.Free;
 S.Free;
 end;
 

(загрузка выше в пустой список)


 procedure TTest.StoreKnownList(Filename: string; List: TList);
 var
 
 S: TFileStream;
 R: TEnhReader;
 K: TKnownObject;
 begin
 
 S := TFileStream.Create(Filename, fmOpenRead;
 R := TEnhReader.Create(S, 1024);
 R.ReadListBegin;
 with List do
 while not EndOfList do
 begin
 K.Create;
 K.Load(R);
 Add(K);
 end;
 R.ReadListEnd;
 end;
 

Методы, которые я добавил к TReader/TWriter, действительно начинают работать только тогда, когда вы имеете дело с объектами двух и более классов (предок и потомок, разные классы от одного родителя и т.п.).


 function TEnhReader.ReadStreamable: TStreamable;
 

Читает из потока имя класса, вызывает FindClass для получения класса и затем создает его экземпляр. Затем вызывает Load для чтения данных объекта. Вероятно вы захотите объявить указатель на возвращаемое значение, имеющее тип последнего общего из всех возможных предков, *не* инициализуруйте это заранее.


 procedure TEnhReader.ReadListItems(List: TList);
 

Список TList должен быть инициализированным, но пустым (будет вызван метод TList.Clear). Читает маркер StartOfList, затем вызывает ReadStreamable до тех пор, пока не достигнет маркера EndOfList, добавляет возвращаемые объекты в список к текущей позиции. Затем читает маркер EndOfList.


 procedure TEnhWriter.WriteStreamable(AObj: TStreamable);
 

Записывает имя класса объекта в поток, затем вызывает Store для записи данных.


 procedure TEnhWriter.WriteListItems(List: TList);
 

Записывает маркер StartOfList, в цикле приводит элементы списка к типу TStreamable и вызывает WriteStreamable для их записи. И, наконец, записывает маркер в конец списка.


 {Базовый класс и его расширения для работы с потоковыми объектами}
 {Авторские права принадлежат Don Croyle}
 
 unit Strmstuf;
 
 interface
 
 uses Classes;
 
 type
 
   TEnhReader = class;
   TEnhWriter = class;
 
   TStreamable = class(TPersistent)
   public
     procedure Load(R: TEnhReader); virtual;
     procedure Store(W: TEnhWriter); virtual;
   end;
 
   TStreamableClass = class of TStreamable;
 
   TEnhReader = class(TReader)
   public
     procedure ReadListItems(List: TList);
     function ReadStreamable: TStreamable;
   end;
 
   TEnhWriter = class(TWriter)
   public
     procedure WriteListItems(List: TList);
     procedure WriteStreamable(AObj: TStreamable);
   end;
 
 implementation
 
 procedure TStreamable.Load(R: TEnhReader);
 begin
 end;
 
 procedure TStreamable.Store(W: TEnhWriter);
 begin
 end;
 
 procedure TEnhReader.ReadListItems(List: TList);
 begin
 
   ReadListBegin;
   with List do
   begin
     Clear;
     while not EndOfList do
       Add(ReadStreamable);
   end;
   ReadListEnd;
 end;
 
 function TEnhReader.ReadStreamable: TStreamable;
 begin
 
   Result := TStreamableClass(FindClass(ReadString)).Create;
   if Result <> nil then
     Result.Load(Self);
 end;
 
 procedure TEnhWriter.WriteListItems(List: TList);
 var
 
   I: Integer;
 begin
 
   WriteListBegin;
   with List do
     for I := 0 to Count - 1 do
       WriteStreamable(TStreamable(Items[I]));
   WriteListEnd;
 end;
 
 procedure TEnhWriter.WriteStreamable(AObj: TStreamable);
 begin
 
   WriteString(AObj.ClassName);
   AObj.Store(Self);
 end;
 
 end.
 




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



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



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


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