From c41d6e135ceed14ab7bde017e27ed978417a01fc Mon Sep 17 00:00:00 2001 From: dkolmck Date: Thu, 6 Aug 2009 14:32:07 +0000 Subject: [PATCH] git-svn-id: https://svn.code.sf.net/p/kolmck/code@9 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07 --- Addons/Errors.pas | 36 + Addons/GRushControls#README#RUS#.txt | 126 + Addons/HeapMM.pas | 122 + Addons/JpegObj.pas | 1885 ++++++ Addons/KOLBlockCipher.pas | 7883 ++++++++++++++++++++++ Addons/KOLCCtrls.pas | 1768 +++++ Addons/KOLEcmListEdit.pas | 955 +++ Addons/KOLEdb.pas | 2209 ++++++ Addons/KOLFontEditor.pas | 424 ++ Addons/KOLGRushControls.pas | 3307 +++++++++ Addons/KOLGif.pas | 2848 ++++++++ Addons/KOLGraphicColor.pas | 4111 +++++++++++ Addons/KOLGraphicCompression.pas | 1648 +++++ Addons/KOLGraphicEx.pas | 6073 +++++++++++++++++ Addons/KOLHTTPDownload.pas | 1138 ++++ Addons/KOLHashs.PAS | 5175 ++++++++++++++ Addons/KOLHttp.pas | 209 + Addons/KOLMHToolTip.pas | 939 +++ Addons/KOLMath.pas | 1780 +++++ Addons/KOLPageSetupDialog.pas | 409 ++ Addons/KOLPcx.pas | 364 + Addons/KOLPrintCommon.pas | 30 + Addons/KOLPrintDialogs.pas | 373 + Addons/KOLPrinters.pas | 663 ++ Addons/KOLProgBar.pas | 359 + Addons/KOLQProgBar.pas | 1541 +++++ Addons/KOLRarBar.pas | 410 ++ Addons/KOLRarProgBar.pas | 377 ++ Addons/KOLRas.pas | 386 ++ Addons/KOLReport.dcr | Bin 0 -> 1368 bytes Addons/KOLReport.pas | 1277 ++++ Addons/KOLSocket.pas | 845 +++ Addons/KOLmdvDBF.pas | 1292 ++++ Addons/KOLmhxp.pas | 53 + Addons/ListEdit.pas | 264 + Addons/MCKGRushButtonEditor.pas | 2570 +++++++ Addons/MCKGRushCheckBoxEditor.pas | 2620 +++++++ Addons/MCKGRushControls.pas | 3110 +++++++++ Addons/MCKGRushControls.res | Bin 0 -> 11768 bytes Addons/MCKGRushImageCollectionEditor.pas | 338 + Addons/MCKGRushPanelEditor.pas | 2147 ++++++ Addons/MCKGRushProgressBarEditor.pas | 2290 +++++++ Addons/MCKGRushRadioBoxEditor.pas | 2620 +++++++ Addons/MCKGRushSplitterEditor.pas | 2605 +++++++ Addons/err.pas | 1197 ++++ Addons/kolTCPSocket.pas | 972 +++ Addons/mckBlockCipher.dcr | Bin 0 -> 8844 bytes Addons/mckBlockCipher.pas | 1092 +++ Addons/mckCCtrls.dcr | Bin 0 -> 3224 bytes Addons/mckCCtrls.pas | 895 +++ Addons/mckCProgBar.dcr | Bin 0 -> 2184 bytes Addons/mckCProgBar.pas | 306 + Addons/mckEcmListEdit.dcr | Bin 0 -> 484 bytes Addons/mckEcmListEdit.pas | 233 + Addons/mckHTTP.dcr | Bin 0 -> 696 bytes Addons/mckHTTP.pas | 154 + Addons/mckHTTPDownload.dcr | Bin 0 -> 1736 bytes Addons/mckHashs.dcr | Bin 0 -> 4444 bytes Addons/mckHashs.pas | 920 +++ 59 files changed, 75348 insertions(+) create mode 100644 Addons/Errors.pas create mode 100644 Addons/GRushControls#README#RUS#.txt create mode 100644 Addons/HeapMM.pas create mode 100644 Addons/JpegObj.pas create mode 100644 Addons/KOLBlockCipher.pas create mode 100644 Addons/KOLCCtrls.pas create mode 100644 Addons/KOLEcmListEdit.pas create mode 100644 Addons/KOLEdb.pas create mode 100644 Addons/KOLFontEditor.pas create mode 100644 Addons/KOLGRushControls.pas create mode 100644 Addons/KOLGif.pas create mode 100644 Addons/KOLGraphicColor.pas create mode 100644 Addons/KOLGraphicCompression.pas create mode 100644 Addons/KOLGraphicEx.pas create mode 100644 Addons/KOLHTTPDownload.pas create mode 100644 Addons/KOLHashs.PAS create mode 100644 Addons/KOLHttp.pas create mode 100644 Addons/KOLMHToolTip.pas create mode 100644 Addons/KOLMath.pas create mode 100644 Addons/KOLPageSetupDialog.pas create mode 100644 Addons/KOLPcx.pas create mode 100644 Addons/KOLPrintCommon.pas create mode 100644 Addons/KOLPrintDialogs.pas create mode 100644 Addons/KOLPrinters.pas create mode 100644 Addons/KOLProgBar.pas create mode 100644 Addons/KOLQProgBar.pas create mode 100644 Addons/KOLRarBar.pas create mode 100644 Addons/KOLRarProgBar.pas create mode 100644 Addons/KOLRas.pas create mode 100644 Addons/KOLReport.dcr create mode 100644 Addons/KOLReport.pas create mode 100644 Addons/KOLSocket.pas create mode 100644 Addons/KOLmdvDBF.pas create mode 100644 Addons/KOLmhxp.pas create mode 100644 Addons/ListEdit.pas create mode 100644 Addons/MCKGRushButtonEditor.pas create mode 100644 Addons/MCKGRushCheckBoxEditor.pas create mode 100644 Addons/MCKGRushControls.pas create mode 100644 Addons/MCKGRushControls.res create mode 100644 Addons/MCKGRushImageCollectionEditor.pas create mode 100644 Addons/MCKGRushPanelEditor.pas create mode 100644 Addons/MCKGRushProgressBarEditor.pas create mode 100644 Addons/MCKGRushRadioBoxEditor.pas create mode 100644 Addons/MCKGRushSplitterEditor.pas create mode 100644 Addons/err.pas create mode 100644 Addons/kolTCPSocket.pas create mode 100644 Addons/mckBlockCipher.dcr create mode 100644 Addons/mckBlockCipher.pas create mode 100644 Addons/mckCCtrls.dcr create mode 100644 Addons/mckCCtrls.pas create mode 100644 Addons/mckCProgBar.dcr create mode 100644 Addons/mckCProgBar.pas create mode 100644 Addons/mckEcmListEdit.dcr create mode 100644 Addons/mckEcmListEdit.pas create mode 100644 Addons/mckHTTP.dcr create mode 100644 Addons/mckHTTP.pas create mode 100644 Addons/mckHTTPDownload.dcr create mode 100644 Addons/mckHashs.dcr create mode 100644 Addons/mckHashs.pas diff --git a/Addons/Errors.pas b/Addons/Errors.pas new file mode 100644 index 0000000..bfcda38 --- /dev/null +++ b/Addons/Errors.pas @@ -0,0 +1,36 @@ +unit Errors; + +interface + +var + ErrorMsg: array[1..21] of string = ( +{01} 'Cannot load image. Invalid or unexpected %s image format.', +{02} 'Invalid color format in %s file.', +{03} 'Stream read error in %s file.', +{04} 'Cannot load image. Unsupported %s image format.', +{05} 'Cannot load image. %s not supported for %s files.', +{06} 'Cannot load image. CRC error found in %s file.', +{07} 'Cannot load image. Compression error found in %s file.', +{08} 'Cannot load image. Extra compressed data found in %s file.', +{09} 'Cannot load image. Palette in %s file is invalid.', +{10} 'Cannot load PNG image. Unexpected but critical chunk detected.', + // features (usually used together with unsupported feature string) +{11} 'The compression scheme is', +{12} 'Image formats other than RGB and RGBA are', +{13} 'File versions other than 3 or 4 are', + // color manager error messages +{14} 'Conversion between indexed and non-indexed pixel formats is not supported.', +{15} 'Color conversion failed. Could not find a proper method.', +{16} 'Color depth is invalid. Bits per sample must be 1,2,4,8 or 16.', +{17} 'Sample count per pixel does not correspond to the given color scheme.', +{18} 'Subsampling value is invalid. Allowed are 1,2 and 4.', +{19} 'Vertical subsampling value must be <= horizontal subsampling value.', + // compression errors +{20} 'LZ77 decompression error.', + // miscellaneous +{21} 'Warning'); + +implementation + +end. + diff --git a/Addons/GRushControls#README#RUS#.txt b/Addons/GRushControls#README#RUS#.txt new file mode 100644 index 0000000..05bca06 --- /dev/null +++ b/Addons/GRushControls#README#RUS#.txt @@ -0,0 +1,126 @@ +----------------------------- +Новости от 14 февраля 2006 г. +GRushControls v0.35 +[+] Добавлен символ условной компиляции USE_MEMSAVEMODE (включен по умолчанию). Думаю все-же не так накладно с точки зрения проиводительности создавать новые Paterns при наведении или нажатии мыши, а удалять сразу как они не будут нужны. В больших проектах может сильно уменьшить количество используемой памяти (и видео кстати тоже). +[*] Процедура BitmapAntialias4X переведена в MMX на асамблер (прирост ее скорости вдвое), что однако не сильно увеличило общую производительность при больших значениях XXX_BorderRoundWidth/Height. По видимому узкое место - GDI, поэтому добавлена функция BitmapAntialias2X (в том числе и с MMX) и по умолчанию теперь используется она (если конечно не отключен новый символ условной компиляции USE_2XAA_INSTEAD_OF_4XAA). +[-] Устранена небольшая утечка из-за отсутствия вызова RemoveProp. +[-] Несколько незначительных багов устранено. +MCK: +[*] Исправлена путаница с некоторыми свойствами. В частности ShadowOffset, так что если вдруг пропали надписи на кнопках - возможно в ShadowOffset установлено значение 255. +[-] Несколько незначительных багов устранено. +[+] Если Вам мало того что GRush стали кушать меньше память, бустрее "сглаживатся" и Вы скептически относитесь к скачиванию новой версии, то эта новость просто обязана поменять Ваше мнение: Для всех MCK керкал появились полноценные Design-time редакторы. Кто попробует - тот оценит! + + +----------------------------- +Новости от 6 февраля 2006 г. +GRushControls v0.34 +[+] Добавлен новый компонент TKOLGRushImageCollection. У него нет "отражения" в KOLGRushControls.pas, а служит он для загрузки изображений. В связи с этим: +[!] Начиная с этой версии модули библиотеки tinyPictures входят в пакет GRushControls и являются его неотъемлемой частью. +[-] Еще раз "Испрвлена потенциальная ошибка, если присвоить All_GlyphBitmap := nil". В предидущей версии поспешил :) +[*] Немного уменшен размер *.dfm файлов, содержащих GRush контролы. +tinyJPGGIFBMP.pas: +[+] Добавлена процедура +procedure tinyLoadJPGGIFBMPResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar); +tinyPNG.pas: +[+] Добавлена функция +function tinyLoadPNGResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar): DWORD; + +Итак что дает этот TKOLGRushImageCollection, и как им пользоватся. Отражение для этого компонента есть нечто иное как PBitmap. В этот битмап с помощию библиотеки tinyPictures подгружается рисунок из ресурсов, используемый как All_GlyphBitmap для контролов, после чего он благополучно уничтожается. Т.е. не смотря на объявление GRushImageCollection1 в классе формы, доступ в runtime к этому объекту запрещен (к сожалению мной, а не компилятором :) ). Основное свойство - ImageType. По умолчанию оно равно None. Если его изменить, появится диалог открытия файла. При открытии графического файла его тип определится автаматически и занесется в ImageType, а содержимое файла будет полностью загружено в ОП (файла, а не картинки). Для освобождения файла нужно просто выбрать ImageType = None. Содержимое файла полностью хранится в *.dfm файле, и наличие оригинального не требуется. +Каждый контрол теперь имеет свойство imagecollection, связывающее его с определенным TKOLGRushImageCollection. Значения параметров All_GlyphWidth и All_GlyphHeight теперь выставляются по следующей схеме: если TKOLGRushControl.GRushStyle.GlyphWidth не равно нулю, то присваевается это значение, если оно равно нулю, но не равно нулю свойство TKOLGRushImageCollestion.ImageWidth, то присваевается это значение. Если же оба свойства равны нулю, то ничего не присвивается и следовательно All_GlyphWidth становится равным All_GlyphBitmap.Width. Для свойства Height все аналогично. + + +----------------------------- +Новости от 31 января 2006 г. +GRushControls v0.33 +[-] "Устранена" псевдо-утечка рессурсов из-зв псевдо-неуничтожения таймера. +[*] Исправлена неверная работа свойств XXX_GlyphItemX, XXX_GlyphItemY, All_GlyphWidth, All_GlyphHeight. +[*] Для избежания конфликтов в именах многие используемые типы получили приставку GRush (TControlType --> TGRushControlType). В основном это внутрение типы, но есть и использевый как параметр для RecalcRects (TRects --> TGrushRects). Его придется переименовывать во всех объявлениях функций для OnRecalcRects. +[*] Разрядность практически всех свойств приведена к 32 (не думаю что с этим могут быть проблемы). +[+] Добавлены свойства: +All_Spacing : DWORD = растояние между текстом и рисунком (если оба присутствуют на элементе) +All_SplitterDotsCount : DWORD = количество серых точек на Splitter. Впрочем никто не мешает изменять его джля других контролов. +[-] Устранена утечка памяти и GDI ресурсов при уничтожении контрола. +[*] Испрвлена потенциальная ошибка, если присвоить All_GlyphBitmap := nil. +MCK: +[-] Убрана лишняя в некоторых случаях генерация байт-кода для Collapse. +[*] Исправлена генерация байт-кода All_ColorCheck и All_UpdateSpeed для CheckBox для Collapse. +[+] Добавлена генерация кода для свойства All_SplitterDotsCount (для Splitter соотвктственно) + + +----------------------------- +Новости от 6 января 2006 г. +GRushControls v0.32 +[+] Добавлено множество символов условной компиляции для уменьшеня кода некоторых проектов. Причем эффект от отключения нескольких символов зачастую больше чем сумма эффектов (в байтах) от отключения каждого по отдельности. По умолчанию включен символ MOSTCOMPATIBILITY, автоматически включающий все остальные. Если хотите отключить какой-либо символ, нужно вначале отключить MOSTCOMPATIBILITY. +[+] Генерация P-кода (байт кода) для системы Collapse обеспечена в полном объеме. Для использования этой возможности нужно объявить ", KOLGRushControls" в файле "CollapseUses.inc" и "GR0O_ = object( TGRushControl ) end;" в "CollapseObjects.inc" (именно такой выход я нашел из сложившейся ситуации - уменьшить имена не свойств, а имя Fake'а для объекта). +[+] Вставил описалова в совместимом с xhelpgen формате. В начале модуля просто каша получилась, без указаной тулзы не прочитать ниче. (Кстати чтобы получить русское описание нужно в ini файле прописать SpecialChar== вместо звездочки). +[+] Теперь свойства XXX_GlyphItemX, XXX_GlyphItemY, All_GlyphWidth, All_GlyphHeight работают так, как я задумывал. Вот небольшой лекбиз на эту тему: + +По умолчанию свойства All_GlyphWidth/All_GlyphHeight (при присвоении All_GlyphBitmap битмапа) устанавливаются равными All_GlyphBitmap.Width/All_GlyphBitmap.Height соответственно. Но это не одно и тоже! Свойства All_GlyphWidth/All_GlyphHeight нужы для формирования своеобразной матрици. Из All_GlyphBitmap как бы получается не одно изображение, а таблица иконок высотой и длиной согласно свойствам All_GlyphWidth/All_GlyphHeight. А для каждого состояния прорисовки определены еще два свойства - XXX_GlyphItemX, XXX_GlyphItemY. Они как раз и говорят о том, какой элемент из этой матрици выбрать. Для пристоты понимания вот пример: Имеем битмап с тремя иконками 32*32 вряд (т.е. сам битмап имеет размер 96*32). Загружаем его в качестве All_GlyphBitmap (при этом All_GlyphWidth=96 All_GlyphHeight=32), меняем All_GlyphWidth:=32, меняем Down_GlyphItemX:=1 Over_GlyphItemX:=2. Получаем эффект как в деме№88 (все бегом смотреть!). Все это нужно для одной очень интересной вещи: Делаем огромный битмап с иконками для всего приложения! Загружаем его и присваиваем All_GlyphBitmap по очереди для всех компонентов. При этом битмап не дублируется, а лиш увеличивается счетчик обращений. После этого, вызываем Free для этого бптмапа (что однако не приводит к его уничтожению, но позволяет уничтожить его после уничтожения последнего использующего его контрола автоматически!). Осталось только настроить координаты GlyphItemX/GlyphItemY для виртуальной матрици иконок! что упрощается write-only свойствами All_GlyphItemX/All_GlyphItemY. + + +----------------------------- +Новости от 11 декабря 2005 г. +GRushControls v0.30.1 +[*] Исправлена утечка системных GDI ресурсов в Windows 98. + + +----------------------------- +Новости от 25 ноября 2005 г. +GRushControls v0.30 +[*] Очень мне не нравятся дела в KOL с функцией DrawTransparent и я решил использовать системную TransparentBlt там, где это возможно. +[*] Наконец-то контролы стали чичтить за собой мусор при уничтожении. Теперь используется CustomObj вмест CustomData +[*] При изменении Caption больше не нужно вызывать SetAllNeedUpdate, теперь он вызывается автоматически +[*] Оптимизированы конструкторы, вынесен общий код +[*] Теперь используется OnPaint вместо перехвата WM_PAINT. Это будет экономить немного кода, если в проекте уже используется OnPaint. Если нет, то немного кода будет экономить директива GRUSH_OLD_PAINT + + +----------------------------- +Новости от 13 ноября 2005 г. +GRushControls v0.29 +news v0.29 от 13.11.05 +[*] Исправлены зеркала, особено для сплиттера и прогрессбара. +[-] Убрано ненужное свойство Vertical у ProgressBar. Его заменило свойство ProgressVertical. +[+] Событие OnProgressChange; +[+] События OnProgressChange, OnRecalcRects можно теперь в зеркале делать. + + +----------------------------- +Новости от 06 ноября 2005 г. +GRushControls v0.28 +[+] В MCK часть добалена практически вся необходимая функциональность. Пока что без загрузки картинок и события OnRecalcRects. +[-] Вылетал со второй формой в PAS_VERSION. Поправлено как в KOL(v2.20), так и уменя (с более ранними версиями тоже будет работать). +[*] Функция GetCPUType перенесена в KOLGRushControls.pas и переименована в CPUisMMX. Остальные проверки убраны. +[-] Если MaxProgress у ProgressBar равен нулю, вылетал. Поправлено. +[+] Максимальное значение для Progress увеличено до большИх пределов. +[*] Приставка gsXXX для констант All_UpdateSpeed изменена на usXXX +[*] NewGRushPanel более не принемает второй параметр (Caption). Теперь его надо задавать как у обычной панели. + + +----------------------------- +Новости от 29 октября 2005 г. +GRushControls v0.27 +[-] Оптимизация кода по размеру на 800 байт. +[+] Новое событие OnRecalcRects вызывается всякий раз когда GRush'и сами изменяют бордеры. +[*] Точка на RadioBox стала без острых углов, организовано как у CheckBox. +[*] В скринах 98 были не закрашеные точки бордера. Что-то с этом сделел, но не могу проверить. :( +[*] CommandActions поправил для правильного AutoSize для CheckBox и RadioBox. +[*] В MCK деме показал, как сделать то, что MTsv DN предложил насчет ProgressBar. + + +----------------------------- +Новости от 23 октября 2005 г. +GRushControls v0.26 +[+] Добавлен компонент GRush Progress Bar. +[+] Добавлены соответствующие свойства у PGRushControl: + All_DrawProgress : Boolean = Отрисовка циферок. + All_DrawProgressRect : Boolean = рисование рамки для ProgressBar + All_ProgressVertical : Boolean = вертикальный или горизонтальный. +[*] Подправлены функции: DeactivateSublings, DoPop, DoPush, DoEnter, DoExit, а также реакция на сообщения WM_TIMER, WM_PAINT, BM_SETCHECK, BM_GETCHECK и т.д. +[*] Если BorderWidth = 0 то он все равно лез. Исправлено. +[*] ShadowOffset был байт, стал смолинт. Может принимать отрицательные значения. + + +----------------------------- +Новости от 22 октября 2005 г. +GRushControls v0.25 +[+] Первый релиз. \ No newline at end of file diff --git a/Addons/HeapMM.pas b/Addons/HeapMM.pas new file mode 100644 index 0000000..51f6322 --- /dev/null +++ b/Addons/HeapMM.pas @@ -0,0 +1,122 @@ +{ + Alternative memory manager. To use it, just place a reference to this + unit *FIRST* in the uses clause of your project (dpr-file). It is a good idea + to use this memory manager with system dcu replacement by Vladimir Kladov. + + Heap API used, which is fast and very effective (allocated block granularity + is 16 bytes). One additional benefit is that some proofing tools (MemProof) + do not detect API failures, which those can find when standard Delphi memory + manager used. + ===================================================================== + Copyright (C) by Vladimir Kladov, 2001 + --------------------------------------------------------------------- + http://xcl.cjb.net + mailto: bonanzas@xcl.cjb.net +} + +unit HeapMM; + +interface + +uses windows; + +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } +implementation + +function HeapGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function HeapFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function HeapReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +{function HeapMemoryManagerSet: Boolean; +begin + Result := TRUE; +end;} + +const + HeapMemoryManager: TMemoryManager = ( + GetMem: HeapGetMem; + FreeMem: HeapFreeMem; + ReallocMem: HeapReallocMem); + +var OldMM: TMemoryManager; + //OldIsMMset: function : Boolean; + +initialization + + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + GetMemoryManager( OldMM ); + //OldIsMMset := IsMemoryManagerSet; + //IsMemoryManagerSet := HeapMemoryManagerSet; + SetMemoryManager( HeapMemoryManager ); + +finalization + + SetMemoryManager( OldMM ); + //IsMemoryManagerSet := OldIsMMset; + {$IFNDEF USE_PROCESS_HEAP} + HeapDestroy( HeapHandle ); + {$ENDIF} + +end. diff --git a/Addons/JpegObj.pas b/Addons/JpegObj.pas new file mode 100644 index 0000000..df806d5 --- /dev/null +++ b/Addons/JpegObj.pas @@ -0,0 +1,1885 @@ +unit JpegObj; +{* Jpeg object. Decompression requires about 54 K (61K when err used). + Compressor part requires extra 30 Kbytes. + |
+ You can define conditional symbol JPEGERR in project options. In such + case exceptions will be used to handle errors, and this will increase + executable size a bit. Though, a practice shows that there are no needs + in exceptions to work correctly even with corrupted jpeg images. Moreover, + refuse from exceptions allows to show partially corrupted images, though + when exceptions are used, such images can not be decoded at all. +} + +//{$DEFINE VER62} // if you plan to use .obj-files from Delphi7 distributive only! + +interface + +{$I KOLDEF.INC} + +{$IFDEF JPEGERR} + {$IFDEF NOJPEGERR} + {$UNDEF NOJPEGERR} + {$ENDIF} +{$ENDIF} + +uses windows, KOL {$IFDEF JPEGERR}, err {$ENDIF}; + +type + PJPEGData = ^TJPEGData; + TJPEGData = object( TObj ) + private + FData: PStream; + FHeight: Integer; + FWidth: Integer; + FGrayscale: Boolean; + protected + public + destructor Destroy; virtual; + procedure Clear; + end; + + TJPEGQualityRange = 1..100; // 100 = best quality, 25 = pretty awful + TJPEGPerformance = (jpBestQuality, jpBestSpeed); + TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth); + TJPEGPixelFormat = (jf24Bit, jf8Bit); + + PJpeg = ^TJpeg; + TJPEGProgress = procedure( Sender: PJpeg; const Rect: TRect; var Stop: Boolean ) + of object; + + TJpeg = object( TObj ) + {* JPeg image incapsulation. If only decoding is used, about 54K of code + is attached to executable. If encoding is used too, about 30K of code + is attached additionally. } + private + FImage: PJPEGData; + FBitmap: PBitmap; + FScaledWidth: Integer; + FScaledHeight: Integer; + FTempPal: HPalette; + FSmoothing: Boolean; + FGrayScale: Boolean; + FPixelFormat: TJPEGPixelFormat; + FQuality: TJPEGQualityRange; + FProgressiveDisplay: Boolean; + FProgressiveEncoding: Boolean; + FPerformance: TJPEGPerformance; + FScale: TJPEGScale; + FNeedRecalc: Boolean; + FOnChange: TOnEvent; + FCorrupted: Boolean; + FOnProgress: TJPEGProgress; + FProgress: function( JPEGobj: PJpeg; const R: TRect ): Boolean; + FCallback: Pointer; + FStop: Boolean; + fProgressTime: Integer; + FCMYK: Boolean; + FConvertCMYK2RGBProc: procedure( Bmp: PBitmap ); + FConvertCMYK2RGB: Boolean; + procedure CalcOutputDimensions; + function GetBitmap: PBitmap; + function GetGrayscale: Boolean; + procedure SetGrayscale(Value: Boolean); + procedure SetPerformance(Value: TJPEGPerformance); + procedure SetPixelFormat(Value: TJPEGPixelFormat); + procedure SetScale(Value: TJPEGScale); + procedure SetSmoothing(Value: Boolean); + procedure SetOnProgress(const Value: TJPEGProgress); + procedure SetBitmap(const Value: PBitmap); + procedure SetConvertCMYK2RGB(const Value: Boolean); + protected + function GetEmpty: Boolean; + {*} + procedure FreeBitmap; + {* Call it to free bitmap, containing decoded JPeg image. } + function GetHeight: Integer; + {*} + function GetWidth: Integer; + {*} + function GetPalette: HPALETTE; + {* } + procedure Changed; + + + // internal methods. Do not know why not placed into 'private' section. + procedure CreateBitmap; + procedure CreateImage; + procedure ReadData(Stream: PStream); + procedure ReadStream(Size: Integer; Stream: PStream); + procedure SetHeight(Value: Integer); + procedure SetPalette(Value: HPalette); + procedure SetWidth(Value: Integer); + procedure WriteData(Stream: PStream); + public + destructor Destroy; virtual; + {*} + procedure Clear; virtual; + {*} + procedure Compress; + {* } + procedure DIBNeeded; + {* } + procedure JPEGNeeded; + {* } + procedure Draw(DC : HDC; X, Y : Integer); + {*} + procedure StretchDraw( DC : HDC; Dest : TRect ); + {*} + + property Palette : HPalette read GetPalette write SetPalette; + {* } + procedure LoadFromStream(Stream: PStream); + {* Loads JPeg image from a stream (from current position). } + procedure SaveToStream(Stream: PStream); + {* Saves JPeg image to a stream. } + function LoadFromFile( const FName : String ) : Boolean; + {* Function to load jpeg image from a file. } + function SaveToFile( const FName : String ) : Boolean; + {* Function to save jpeg image into a file. } + + // Options affecting / reflecting compression and decompression behavior + property Grayscale: Boolean read GetGrayscale write SetGrayscale; + {* } + property ProgressiveEncoding: Boolean read FProgressiveEncoding write FProgressiveEncoding; + {* } + + // Compression options + property CompressionQuality: TJPEGQualityRange read FQuality write FQuality; + {* Compression quality. } + + // Decompression options + property PixelFormat: TJPEGPixelFormat read FPixelFormat write SetPixelFormat; + {* } + + {* Format of decompressed bitmap. } + property ProgressiveDisplay: Boolean read FProgressiveDisplay write FProgressiveDisplay; + {* } + property Performance: TJPEGPerformance read FPerformance write SetPerformance; + {* } + property Scale: TJPEGScale read FScale write SetScale; + {* } + property Smoothing: Boolean read FSmoothing write SetSmoothing; + {* True, if smoothing is enabled due decompression. } + + property Bitmap: PBitmap read GetBitmap write SetBitmap; + {* Returns decompressed jpeg image as a bitmap. To detect if an image + is corrupted, check Corrupted property after requesting the Bitmap. + |
+ Assign a TBitmap object to this property before calling method + SaveToStream or SaveToFile to convert bitmap image to jpeg format. } + property Empty: Boolean read GetEmpty; + {* Returns True, if empty. } + + property OnChange: TOnEvent read FOnChange write FOnChange; + {* Is called when the image is changed. } + property Width: Integer read GetWidth; + {* } + property Height: Integer read GetHeight; + {* } + property Corrupted: Boolean read FCorrupted; + {* True, when an image is corrupted. This can be detected only AFTER + Bitmap is requested, not just after loading the image. } + property OnProgress: TJPEGProgress read FOnProgress write SetOnProgress; + {* This event is called while decompressing (or compressing) the image. + If You want paint portion of decompressed image, use Bitmap method + DIBDrawRect, which does not change its DIBBits location during decoding. + Otherwise, the abnormal termination can be caused. } + property ProgressTime: Integer read fProgressTime write fProgressTime; + {* By default, 100 milliseconds. Change this period to change frequency + of OnProgress event calls during the compression / decompression. } + property ConvertCMYK2RGB: Boolean read FConvertCMYK2RGB write SetConvertCMYK2RGB; + {* Set it to true to convert decoded CMYK image to RGB. } + end; + + TJPEGDefaults = record + CompressionQuality: TJPEGQualityRange; + Grayscale: Boolean; + Performance: TJPEGPerformance; + PixelFormat: TJPEGPixelFormat; + ProgressiveDisplay: Boolean; + ProgressiveEncoding: Boolean; + Scale: TJPEGScale; + Smoothing: Boolean; + end; + +function NewJpeg: PJpeg; +{* Constructs new TJpeg object. } + +var // Default settings for all new TJPEGImage instances + JPEGDefaults: TJPEGDefaults = ( + CompressionQuality: 90; + Grayscale: False; + Performance: jpBestQuality; + PixelFormat: jf24Bit; // initialized to match video mode + ProgressiveDisplay: False; + ProgressiveEncoding: False; + Scale: jsFullSize; + Smoothing: True; + ); + +implementation + +{ The following types and external function declarations are used to + call into functions of the Independent JPEG Group's (IJG) implementation + of the JPEG image compression/decompression public standard. The IJG + library's C source code is compiled into OBJ files and linked into + the Delphi application. Only types and functions needed by this unit + are declared; all IJG internal structures are stubbed out with + generic pointers to reduce internal source code congestion. + + IJG source code copyright (C) 1991-1996, Thomas G. Lane. } + +{$Z4} // Minimum enum size = dword + +const + JPEG_LIB_VERSION = {$IFDEF VER62} 62 {$ELSE} 61 {$ENDIF}; { Version 6a } + + JPEG_RST0 = $D0; { RST0 marker code } + JPEG_EOI = $D9; { EOI marker code } + JPEG_APP0 = $E0; { APP0 marker code } + JPEG_COM = $FE; { COM marker code } + + DCTSIZE = 8; { The basic DCT block is 8x8 samples } + DCTSIZE2 = 64; { DCTSIZE squared; # of elements in a block } + NUM_QUANT_TBLS = 4; { Quantization tables are numbered 0..3 } + NUM_HUFF_TBLS = 4; { Huffman tables are numbered 0..3 } + NUM_ARITH_TBLS = 16; { Arith-coding tables are numbered 0..15 } + MAX_COMPS_IN_SCAN = 4; { JPEG limit on # of components in one scan } + MAX_SAMP_FACTOR = 4; { JPEG limit on sampling factors } + C_MAX_BLOCKS_IN_MCU = 10; { compressor's limit on blocks per MCU } + D_MAX_BLOCKS_IN_MCU = 10; { decompressor's limit on blocks per MCU } + MAX_COMPONENTS = 10; { maximum number of image components (color channels) } + + MAXJSAMPLE = 255; + CENTERJSAMPLE = 128; + +type + JSAMPLE = byte; + GETJSAMPLE = integer; + JCOEF = integer; + JCOEF_PTR = ^JCOEF; + UINT8 = byte; + UINT16 = Word; + UINT = Cardinal; + INT16 = SmallInt; + INT32 = Integer; + INT32PTR = ^INT32; + JDIMENSION = Cardinal; + + JOCTET = Byte; + jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1; + JOCTET_FIELD = array[jTOctet] of JOCTET; + JOCTET_FIELD_PTR = ^JOCTET_FIELD; + JOCTETPTR = ^JOCTET; + + JSAMPLE_PTR = ^JSAMPLE; + JSAMPROW_PTR = ^JSAMPROW; + + jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1; + JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far} + JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. } + + jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1; + JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW; + JSAMPARRAY = ^JSAMPROW_ARRAY; { ptr to some rows (a 2-D sample array) } + + jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1; + JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY; + JSAMPIMAGE = ^JSAMP_ARRAY; { a 3-D sample array: top index is color } + +const + CSTATE_START = 100; { after create_compress } + CSTATE_SCANNING = 101; { start_compress done, write_scanlines OK } + CSTATE_RAW_OK = 102; { start_compress done, write_raw_data OK } + CSTATE_WRCOEFS = 103; { jpeg_write_coefficients done } + DSTATE_START = 200; { after create_decompress } + DSTATE_INHEADER = 201; { reading header markers, no SOS yet } + DSTATE_READY = 202; { found SOS, ready for start_decompress } + DSTATE_PRELOAD = 203; { reading multiscan file in start_decompress} + DSTATE_PRESCAN = 204; { performing dummy pass for 2-pass quant } + DSTATE_SCANNING = 205; { start_decompress done, read_scanlines OK } + DSTATE_RAW_OK = 206; { start_decompress done, read_raw_data OK } + DSTATE_BUFIMAGE = 207; { expecting jpeg_start_output } + DSTATE_BUFPOST = 208; { looking for SOS/EOI in jpeg_finish_output } + DSTATE_RDCOEFS = 209; { reading file in jpeg_read_coefficients } + DSTATE_STOPPING = 210; { looking for EOI in jpeg_finish_decompress } + +{ Known color spaces. } + +type + J_COLOR_SPACE = ( + JCS_UNKNOWN, { error/unspecified } + JCS_GRAYSCALE, { monochrome } + JCS_RGB, { red/green/blue } + JCS_YCbCr, { Y/Cb/Cr (also known as YUV) } + JCS_CMYK, { C/M/Y/K } + JCS_YCCK { Y/Cb/Cr/K } + ); + +{ DCT/IDCT algorithm options. } + +type + J_DCT_METHOD = ( + JDCT_ISLOW, { slow but accurate integer algorithm } + JDCT_IFAST, { faster, less accurate integer method } + JDCT_FLOAT { floating-point: accurate, fast on fast HW (Pentium)} + ); + +{ Dithering options for decompression. } + +type + J_DITHER_MODE = ( + JDITHER_NONE, { no dithering } + JDITHER_ORDERED, { simple ordered dither } + JDITHER_FS { Floyd-Steinberg error diffusion dither } + ); + +{ Error handler } + +const + JMSG_LENGTH_MAX = 200; { recommended size of format_message buffer } + JMSG_STR_PARM_MAX = 80; + + JPOOL_PERMANENT = 0; // lasts until master record is destroyed + JPOOL_IMAGE = 1; // lasts until done with image/datastream + +type + jpeg_error_mgr_ptr = ^jpeg_error_mgr; + jpeg_progress_mgr_ptr = ^jpeg_progress_mgr; + + j_common_ptr = ^jpeg_common_struct; + j_compress_ptr = ^jpeg_compress_struct; + j_decompress_ptr = ^jpeg_decompress_struct; + +{ Routine signature for application-supplied marker processing methods. + Need not pass marker code since it is stored in cinfo^.unread_marker. } + + jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : LongBool; + + jpeg_saved_marker_ptr = ^jpeg_marker_struct; + + jpeg_marker_struct = record + next: jpeg_saved_marker_ptr; { next in list, or NULL } + marker: Byte; { marker code: JPEG_COM, or JPEG_APP0+n } + original_length: LongWord; { # bytes of data in the file } + data_length: LongWord; { # bytes of data saved at data[] } + data: JOCTETPTR; { the data contained in the marker } + { the marker length word is not counted in data_length or original_length } + end; + +{ Marker reading & parsing } + jpeg_marker_reader_ptr = ^jpeg_marker_reader; + jpeg_marker_reader = record + reset_marker_reader : procedure(cinfo : j_decompress_ptr); + { Read markers until SOS or EOI. + Returns same codes as are defined for jpeg_consume_input: + JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. } + + read_markers : function (cinfo : j_decompress_ptr) : Integer; + { Read a restart marker --- exported for use by entropy decoder only } + read_restart_marker : jpeg_marker_parser_method; + { Application-overridable marker processing methods } + process_COM : jpeg_marker_parser_method; + process_APPn : Array[0..16-1] of jpeg_marker_parser_method; + + { State of marker reader --- nominally internal, but applications + supplying COM or APPn handlers might like to know the state. } + + saw_SOI : LongBool; { found SOI? } + saw_SOF : LongBool; { found SOF? } + next_restart_num : Integer; { next restart number expected (0-7) } + discarded_bytes : UINT; { # of bytes skipped looking for a marker } + end; + + {int8array = Array[0..8-1] of int;} + int8array = Array[0..8-1] of Integer; + + jpeg_error_mgr = record + { Error exit handler: does not return to caller } + error_exit : procedure (cinfo : j_common_ptr); + { Conditionally emit a trace or warning message } + emit_message : procedure (cinfo : j_common_ptr; msg_level : Integer); + { Routine that actually outputs a trace or error message } + output_message : procedure (cinfo : j_common_ptr); + { Format a message string for the most recent JPEG error or message } + format_message : procedure (cinfo : j_common_ptr; buffer: PChar); + { Reset error state variables at start of a new image } + reset_error_mgr : procedure (cinfo : j_common_ptr); + + { The message ID code and any parameters are saved here. + A message can have one string parameter or up to 8 int parameters. } + + msg_code : Integer; + + msg_parm : record + case byte of + 0:(i : int8array); + {$IFDEF VER62} + 1:(s : array[0..JMSG_STR_PARM_MAX - 1] of char); + {$ELSE} + 1:(s : string[JMSG_STR_PARM_MAX]); + {$ENDIF} + end; + trace_level : Integer; { max msg_level that will be displayed } + num_warnings : Integer; { number of corrupt-data warnings } + {$IFDEF VER62} + jpeg_message_table: ^PChar; { Library errors } + last_jpeg_message: Integer; { Table contains strings 0..last_jpeg_message } + { Second table can be added by application (see cjpeg/djpeg for example). + It contains strings numbered first_addon_message..last_addon_message. + } + addon_message_table: ^PChar; { Non-library errors } + first_addon_message: Integer; { code for first string in addon table } + last_addon_message: Integer; { code for last string in addon table } + {$ENDIF} + end; + + +{ Data destination object for compression } + jpeg_destination_mgr_ptr = ^jpeg_destination_mgr; + jpeg_destination_mgr = record + next_output_byte : JOCTETptr; { => next byte to write in buffer } + free_in_buffer : Longint; { # of byte spaces remaining in buffer } + + init_destination : procedure (cinfo : j_compress_ptr); + empty_output_buffer : function (cinfo : j_compress_ptr) : LongBool; + term_destination : procedure (cinfo : j_compress_ptr); + end; + + +{ Data source object for decompression } + + jpeg_source_mgr_ptr = ^jpeg_source_mgr; + jpeg_source_mgr = record + next_input_byte : JOCTETptr; { => next byte to read from buffer } + bytes_in_buffer : Longint; { # of bytes remaining in buffer } + + init_source : procedure (cinfo : j_decompress_ptr); + fill_input_buffer : function (cinfo : j_decompress_ptr) : LongBool; + skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : Longint); + resync_to_restart : function (cinfo : j_decompress_ptr; + desired : Integer) : LongBool; + term_source : procedure (cinfo : j_decompress_ptr); + end; + +{ JPEG library memory manger routines } + jpeg_memory_mgr_ptr = ^jpeg_memory_mgr; + jpeg_memory_mgr = record + { Method pointers } + alloc_small : function (cinfo : j_common_ptr; + pool_id, sizeofobject: Integer): pointer; + alloc_large : function (cinfo : j_common_ptr; + pool_id, sizeofobject: Integer): pointer; + alloc_sarray : function (cinfo : j_common_ptr; pool_id : Integer; + samplesperrow : JDIMENSION; + numrows : JDIMENSION) : JSAMPARRAY; + alloc_barray : pointer; + request_virt_sarray : pointer; + request_virt_barray : pointer; + realize_virt_arrays : pointer; + access_virt_sarray : pointer; + access_virt_barray : pointer; + free_pool : pointer; + self_destruct : pointer; + max_memory_to_use : Longint; + end; + + { Fields shared with jpeg_decompress_struct } + jpeg_common_struct = packed record + err : jpeg_error_mgr_ptr; { Error handler module } + mem : jpeg_memory_mgr_ptr; { Memory manager module } + progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } + {$IFDEF VER62} + client_data: Pointer; { Available for use by application } + {$ENDIF} + is_decompressor : LongBool; { so common code can tell which is which } + global_state : Integer; { for checking call sequence validity } + end; + +{ Progress monitor object } + + jpeg_progress_mgr = record + progress_monitor : procedure(const cinfo : jpeg_common_struct); + pass_counter : Integer; { work units completed in this pass } + pass_limit : Integer; { total number of work units in this pass } + completed_passes : Integer; { passes completed so far } + total_passes : Integer; { total number of passes expected } + // extra Delphi info + instance: PJpeg; // ptr to current PJpeg object + last_pass: Integer; + last_pct: Integer; + last_time: Integer; + last_scanline: Integer; + end; + + +{ Master record for a compression instance } + + jpeg_compress_struct = {$IFNDEF VER62} packed {$ENDIF} record + common: jpeg_common_struct; + + dest : jpeg_destination_mgr_ptr; { Destination for compressed data } + + { Description of source image --- these fields must be filled in by + outer application before starting compression. in_color_space must + be correct before you can even call jpeg_set_defaults(). } + + image_width : JDIMENSION; { input image width } + image_height : JDIMENSION; { input image height } + input_components : Integer; { # of color components in input image } + in_color_space : J_COLOR_SPACE; { colorspace of input image } + input_gamma : double; { image gamma of input image } + + // Compression parameters + data_precision : Integer; { bits of precision in image data } + num_components : Integer; { # of color components in JPEG image } + jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } + comp_info : Pointer; + quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of Pointer; + dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer; + ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer; + arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } + arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } + arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } + num_scans : Integer; { # of entries in scan_info array } + scan_info : Pointer; { script for multi-scan file, or NIL } + raw_data_in : LongBool; { TRUE=caller supplies downsampled data } + arith_code : LongBool; { TRUE=arithmetic coding, FALSE=Huffman } + optimize_coding : LongBool; { TRUE=optimize entropy encoding parms } + CCIR601_sampling : LongBool; { TRUE=first samples are cosited } + smoothing_factor : Integer; { 1..100, or 0 for no input smoothing } + dct_method : J_DCT_METHOD; { DCT algorithm selector } + restart_interval : UINT; { MCUs per restart, or 0 for no restart } + restart_in_rows : Integer; { if > 0, MCU rows per restart interval } + + { Parameters controlling emission of special markers. } + write_JFIF_header : LongBool; { should a JFIF marker be written? } + {$IFDEF VER62} + JFIF_major_version: UINT8; { What to write for a JFIF version number } + JFIF_minor_version: UINT8; + {$ENDIF} + { These three values are not used by the JPEG code, merely copied } + { into the JFIF APP0 marker. density_unit can be 0 for unknown, } + { 1 for dots/inch, or 2 for dots/cm. Note that the pixel aspect } + { ratio is defined by X_density/Y_density even when density_unit=0. } + density_unit : UINT8; { JFIF code for pixel size units } + X_density : UINT16; { Horizontal pixel density } + Y_density : UINT16; { Vertical pixel density } + write_Adobe_marker : LongBool; { should an Adobe marker be written? } + + { State variable: index of next scanline to be written to + jpeg_write_scanlines(). Application may use this to control its + processing loop, e.g., "while (next_scanline < image_height)". } + + next_scanline : JDIMENSION; { 0 .. image_height-1 } + + { Remaining fields are known throughout compressor, but generally + should not be touched by a surrounding application. } + progressive_mode : LongBool; { TRUE if scan script uses progressive mode } + max_h_samp_factor : Integer; { largest h_samp_factor } + max_v_samp_factor : Integer; { largest v_samp_factor } + total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr } + comps_in_scan : Integer; { # of JPEG components in this scan } + cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer; + MCUs_per_row : JDIMENSION; { # of MCUs across the image } + MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image } + blocks_in_MCU : Integer; { # of DCT blocks per MCU } + MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of Integer; + Ss, Se, Ah, Al : Integer; { progressive JPEG parameters for scan } + + { Links to compression subobjects (methods and private variables of modules) } + master : Pointer; + main : Pointer; + prep : Pointer; + coef : Pointer; + marker : Pointer; + cconvert : Pointer; + downsample : Pointer; + fdct : Pointer; + entropy : Pointer; + {$IFDEF VER62} + script_space: Pointer; { workspace for jpeg_simple_progression } + script_space_size: Integer; + {$ENDIF} + end; + + +{ Master record for a decompression instance } + + jpeg_decompress_struct = {$IFNDEF VER62} packed {$ENDIF} record + common: jpeg_common_struct; + + { Source of compressed data } + src : jpeg_source_mgr_ptr; + + { Basic description of image --- filled in by jpeg_read_header(). } + { Application may inspect these values to decide how to process image. } + + image_width : JDIMENSION; { nominal image width (from SOF marker) } + image_height : JDIMENSION; { nominal image height } + num_components : Integer; { # of color components in JPEG image } + jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } + + { Decompression processing parameters } + out_color_space : J_COLOR_SPACE; { colorspace for output } + scale_num, scale_denom : uint ; { fraction by which to scale image } + output_gamma : double; { image gamma wanted in output } + buffered_image : LongBool; { TRUE=multiple output passes } + raw_data_out : LongBool; { TRUE=downsampled data wanted } + dct_method : J_DCT_METHOD; { IDCT algorithm selector } + do_fancy_upsampling : LongBool; { TRUE=apply fancy upsampling } + do_block_smoothing : LongBool; { TRUE=apply interblock smoothing } + quantize_colors : LongBool; { TRUE=colormapped output wanted } + { the following are ignored if not quantize_colors: } + dither_mode : J_DITHER_MODE; { type of color dithering to use } + two_pass_quantize : LongBool; { TRUE=use two-pass color quantization } + desired_number_of_colors : Integer; { max # colors to use in created colormap } + { these are significant only in buffered-image mode: } + enable_1pass_quant : LongBool; { enable future use of 1-pass quantizer } + enable_external_quant : LongBool; { enable future use of external colormap } + enable_2pass_quant : LongBool; { enable future use of 2-pass quantizer } + + { Description of actual output image that will be returned to application. + These fields are computed by jpeg_start_decompress(). + You can also use jpeg_calc_output_dimensions() to determine these values + in advance of calling jpeg_start_decompress(). } + + output_width : JDIMENSION; { scaled image width } + output_height: JDIMENSION; { scaled image height } + out_color_components : Integer; { # of color components in out_color_space } + output_components : Integer; { # of color components returned } + { output_components is 1 (a colormap index) when quantizing colors; + otherwise it equals out_color_components. } + + rec_outbuf_height : Integer; { min recommended height of scanline buffer } + { If the buffer passed to jpeg_read_scanlines() is less than this many + rows high, space and time will be wasted due to unnecessary data + copying. Usually rec_outbuf_height will be 1 or 2, at most 4. } + + { When quantizing colors, the output colormap is described by these + fields. The application can supply a colormap by setting colormap + non-NIL before calling jpeg_start_decompress; otherwise a colormap + is created during jpeg_start_decompress or jpeg_start_output. The map + has out_color_components rows and actual_number_of_colors columns. } + + actual_number_of_colors : Integer; { number of entries in use } + colormap : JSAMPARRAY; { The color map as a 2-D pixel array } + + { State variables: these variables indicate the progress of decompression. + The application may examine these but must not modify them. } + + { Row index of next scanline to be read from jpeg_read_scanlines(). + Application may use this to control its processing loop, e.g., + "while (output_scanline < output_height)". } + + output_scanline : JDIMENSION; { 0 .. output_height-1 } + + { Current input scan number and number of iMCU rows completed in scan. + These indicate the progress of the decompressor input side. } + + input_scan_number : Integer; { Number of SOS markers seen so far } + input_iMCU_row : JDIMENSION; { Number of iMCU rows completed } + + { The "output scan number" is the notional scan being displayed by the + output side. The decompressor will not allow output scan/row number + to get ahead of input scan/row, but it can fall arbitrarily far behind.} + + output_scan_number : Integer; { Nominal scan number being displayed } + output_iMCU_row : Integer; { Number of iMCU rows read } + + coef_bits : Pointer; + + { Internal JPEG parameters --- the application usually need not look at + these fields. Note that the decompressor output side may not use + any parameters that can change between scans. } + + { Quantization and Huffman tables are carried forward across input + datastreams when processing abbreviated JPEG datastreams. } + + quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of Pointer; + dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer; + ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer; + + { These parameters are never carried across datastreams, since they + are given in SOF/SOS markers or defined to be reset by SOI. } + data_precision : Integer; { bits of precision in image data } + comp_info : Pointer; + progressive_mode : LongBool; { TRUE if SOFn specifies progressive mode } + arith_code : LongBool; { TRUE=arithmetic coding, FALSE=Huffman } + arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } + arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } + arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } + + restart_interval : UINT; { MCUs per restart interval, or 0 for no restart } + + { These fields record data obtained from optional markers recognized by + the JPEG library. } + saw_JFIF_marker : LongBool; { TRUE iff a JFIF APP0 marker was found } + { Data copied from JFIF marker: } + {$IFDEF VER62} + JFIF_major_version: UINT8; { JFIF version number } + JFIF_minor_version: UINT8; + {$ENDIF} + density_unit : UINT8; { JFIF code for pixel size units } + X_density : UINT16; { Horizontal pixel density } + Y_density : UINT16; { Vertical pixel density } + saw_Adobe_marker : LongBool; { TRUE iff an Adobe APP14 marker was found } + Adobe_transform : UINT8; { Color transform code from Adobe marker } + + CCIR601_sampling : LongBool; { TRUE=first samples are cosited } + + {$IFDEF VER62} + { Aside from the specific data retained from APPn markers known to the + library, the uninterpreted contents of any or all APPn and COM markers + can be saved in a list for examination by the application. } + marker_list: jpeg_saved_marker_ptr; { Head of list of saved markers } + {$ENDIF} + + { Remaining fields are known throughout decompressor, but generally + should not be touched by a surrounding application. } + max_h_samp_factor : Integer; { largest h_samp_factor } + max_v_samp_factor : Integer; { largest v_samp_factor } + min_DCT_scaled_size : Integer; { smallest DCT_scaled_size of any component } + total_iMCU_rows : JDIMENSION; { # of iMCU rows in image } + sample_range_limit : Pointer; { table for fast range-limiting } + + { These fields are valid during any one scan. + They describe the components and MCUs actually appearing in the scan. + Note that the decompressor output side must not use these fields. } + comps_in_scan : Integer; { # of JPEG components in this scan } + cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer; + MCUs_per_row : JDIMENSION; { # of MCUs across the image } + MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image } + blocks_in_MCU : JDIMENSION; { # of DCT blocks per MCU } + MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of Integer; + Ss, Se, Ah, Al : Integer; { progressive JPEG parameters for scan } + + { This field is shared between entropy decoder and marker parser. + It is either zero or the code of a JPEG marker that has been + read from the data source, but has not yet been processed. } + unread_marker : Integer; + + { Links to decompression subobjects + (methods, private variables of modules) } + master : Pointer; + main : Pointer; + coef : Pointer; + post : Pointer; + inputctl : Pointer; + marker : Pointer; + entropy : Pointer; + idct : Pointer; + upsample : Pointer; + cconvert : Pointer; + cquantize : Pointer; + end; + + TJPEGContext = record + err: jpeg_error_mgr; + progress: jpeg_progress_mgr; + FinalDCT: J_DCT_METHOD; + FinalTwoPassQuant: Boolean; + FinalDitherMode: J_DITHER_MODE; + case byte of + 0: (common: jpeg_common_struct); + 1: (d: jpeg_decompress_struct); + 2: (c: jpeg_compress_struct); + end; + +{ Decompression startup: read start of JPEG datastream to see what's there + function jpeg_read_header (cinfo : j_decompress_ptr; + require_image : LongBool) : Integer; + Return value is one of: } +const + JPEG_SUSPENDED = 0; { Suspended due to lack of input data } + JPEG_HEADER_OK = 1; { Found valid image datastream } + JPEG_HEADER_TABLES_ONLY = 2; { Found valid table-specs-only datastream } +{ If you pass require_image = TRUE (normal case), you need not check for + a TABLES_ONLY return code; an abbreviated file will cause an error exit. + JPEG_SUSPENDED is only possible if you use a data source module that can + give a suspension return (the stdio source module doesn't). } + + +{ function jpeg_consume_input (cinfo : j_decompress_ptr) : Integer; + Return value is one of: } + + JPEG_REACHED_SOS = 1; { Reached start of new scan } + JPEG_REACHED_EOI = 2; { Reached end of image } + JPEG_ROW_COMPLETED = 3; { Completed one iMCU row } + JPEG_SCAN_COMPLETED = 4; { Completed last iMCU row of a scan } + + +// Stubs for external C RTL functions referenced by JPEG OBJ files. + +function _malloc(size: Integer): Pointer; cdecl; +begin + GetMem(Result, size); +end; + +procedure _free(P: Pointer); cdecl; +begin + FreeMem(P); +end; + +procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl; +begin + FillChar(P^, count, B); +end; + +procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; +begin + Move(source^, dest^, count); +end; + +function _fread(var buf; recsize, reccount: Integer; S: PStream): Integer; cdecl; +begin + Result := S.Read(buf, recsize * reccount); +end; + +function _fwrite(var buf; recsize, reccount: Integer; S: PStream): Integer; cdecl; +begin + Result := S.Write(buf, recsize * reccount); +end; + +function _fflush(S: PStream): Integer; cdecl; +begin + Result := 0; +end; + +function __ftol: Integer; +var + f: double; +begin + asm + lea eax, f // BC++ passes floats on the FPU stack + fstp qword ptr [eax] // Delphi passes floats on the CPU stack + end; + Result := Integer(Trunc(f)); +end; + +var + __turboFloat: LongBool = False; + +{$L JPegObj\jdapimin.obj} +{$L JPegObj\jmemmgr.obj} +{$L JPegObj\jmemnobs.obj} +{$L JPegObj\jdinput.obj} +{$L JPegObj\jdatasrc.obj} +{$L JPegObj\jdapistd.obj} +{$L JPegObj\jdmaster.obj} +{$L JPegObj\jdphuff.obj} +{$L JPegObj\jdhuff.obj} +{$L JPegObj\jdmerge.obj} +{$L JPegObj\jdcolor.obj} +{$L JPegObj\jquant1.obj} +{$L JPegObj\jquant2.obj} +{$L JPegObj\jdmainct.obj} +{$L JPegObj\jdcoefct.obj} +{$L JPegObj\jdpostct.obj} +{$L JPegObj\jddctmgr.obj} +{$L JPegObj\jdsample.obj} +{$L JPegObj\jidctflt.obj} +{$L JPegObj\jidctfst.obj} +{$L JPegObj\jidctint.obj} +{$L JPegObj\jidctred.obj} +{$L JPegObj\jdmarker.obj} +{$L JPegObj\jutils.obj} +{$L JPegObj\jcomapi.obj} + +procedure jpeg_CreateDecompress (var cinfo : jpeg_decompress_struct; + version : integer; structsize : integer); external; +procedure jpeg_stdio_src(var cinfo: jpeg_decompress_struct; + input_file: PStream); external; +procedure jpeg_read_header(var cinfo: jpeg_decompress_struct; + RequireImage: LongBool); external; +procedure jpeg_calc_output_dimensions(var cinfo: jpeg_decompress_struct); external; +function jpeg_start_decompress(var cinfo: jpeg_decompress_struct): Longbool; external; +function jpeg_read_scanlines(var cinfo: jpeg_decompress_struct; + scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external; +function jpeg_finish_decompress(var cinfo: jpeg_decompress_struct): Longbool; external; +procedure jpeg_destroy_decompress (var cinfo : jpeg_decompress_struct); external; +function jpeg_has_multiple_scans(var cinfo: jpeg_decompress_struct): Longbool; external; +function jpeg_consume_input(var cinfo: jpeg_decompress_struct): Integer; external; +function jpeg_start_output(var cinfo: jpeg_decompress_struct; scan_number: Integer): Longbool; external; +function jpeg_finish_output(var cinfo: jpeg_decompress_struct): LongBool; external; +procedure jpeg_destroy(var cinfo: jpeg_common_struct); external; + +{$L JPegObj\jdatadst.obj} +{$L JPegObj\jcparam.obj} +{$L JPegObj\jcapistd.obj} +{$L JPegObj\jcapimin.obj} +{$L JPegObj\jcinit.obj} +{$L JPegObj\jcmarker.obj} +{$L JPegObj\jcmaster.obj} +{$L JPegObj\jcmainct.obj} +{$L JPegObj\jcprepct.obj} +{$L JPegObj\jccoefct.obj} +{$L JPegObj\jccolor.obj} +{$L JPegObj\jcsample.obj} +{$L JPegObj\jcdctmgr.obj} +{$L JPegObj\jcphuff.obj} +{$L JPegObj\jfdctint.obj} +{$L JPegObj\jfdctfst.obj} +{$L JPegObj\jfdctflt.obj} +{$L JPegObj\jchuff.obj} + +procedure jpeg_CreateCompress (var cinfo : jpeg_compress_struct; + version : integer; structsize : integer); external; +procedure jpeg_stdio_dest(var cinfo: jpeg_compress_struct; + output_file: PStream); external; +procedure jpeg_set_defaults(var cinfo: jpeg_compress_struct); external; +procedure jpeg_set_quality(var cinfo: jpeg_compress_struct; Quality: Integer; + Baseline: Longbool); external; +procedure jpeg_set_colorspace(var cinfo: jpeg_compress_struct; + colorspace: J_COLOR_SPACE); external; +procedure jpeg_simple_progression(var cinfo: jpeg_compress_struct); external; +procedure jpeg_start_compress(var cinfo: jpeg_compress_struct; + WriteAllTables: LongBool); external; +function jpeg_write_scanlines(var cinfo: jpeg_compress_struct; + scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external; +procedure jpeg_finish_compress(var cinfo: jpeg_compress_struct); external; + +var Jpeg_Error: Boolean = FALSE; + +procedure InvalidOperation(const Msg: string); near; +begin + //raise EInvalidGraphicOperation.Create(Msg); + //MessageBox( 0, PChar(Msg), 'JPeg message: Invalid Operation', MB_OK ); + {$IFDEF JPEGERR} + raise Exception.Create( e_Convert, 'Jpeg: InvalidOp' ); + {$ELSE} + Jpeg_Error := TRUE; + {$ENDIF} +end; + +procedure JpegError(cinfo: j_common_ptr); +begin + //TODO: raise EJPEG.CreateFmt(sJPEGError,[cinfo^.err^.msg_code]); + + {MessageBox( 0, PChar( 'JPeg error ' + #13 + + 'err: ' + Int2Str( Integer( cinfo.err ) ) + #13 + + 'mem: ' + Int2Str( Integer( cinfo.mem ) ) + #13 + + 'progress: ' + Int2Str( Integer( cinfo.progress ) ) + #13 + + 'is_decompressor: ' + Int2Str( Integer( cinfo.is_decompressor ) ) + #13 + + 'global_state: ' + Int2Str( cinfo.global_state ) ), + 'JPeg error', MB_OK );} + + {$IFDEF JPEGERR} + raise Exception.CreateFmt( e_Convert, + 'Jpeg error: %d, mem: %d, progress: %d, isDecompressor: %d, globalState: %d', + [ cinfo.err, cinfo.mem, cinfo.progress, cinfo.is_decompressor, cinfo.global_state ] ); + {$ELSE} + Jpeg_Error := TRUE; + {$ENDIF} +end; + +procedure EmitMessage(cinfo: j_common_ptr; msg_level: Integer); +begin + //!! +end; + +procedure OutputMessage(cinfo: j_common_ptr); +begin + //!! +end; + +procedure FormatMessage(cinfo: j_common_ptr; buffer: PChar); +begin + //!! +end; + +procedure ResetErrorMgr(cinfo: j_common_ptr); +begin + cinfo^.err^.num_warnings := 0; + cinfo^.err^.msg_code := 0; +end; + + +const + jpeg_std_error: jpeg_error_mgr = ( + error_exit: JpegError; + emit_message: EmitMessage; + output_message: OutputMessage; + format_message: FormatMessage; + reset_error_mgr: ResetErrorMgr); + +{ TJPEGData } + +procedure TJPEGData.Clear; +begin + if FData <> nil then + FData.Size := 0; + FWidth := 0; + FHeight := 0; +end; + +destructor TJPEGData.Destroy; +begin + FData.Free; + inherited; +end; + +procedure DummyProgressCallback( const cinfo: jpeg_common_struct ); +begin + // * nothing * +end; + +procedure ProgressCallback(const cinfo: jpeg_common_struct); +var + Ticks: Integer; + R: TRect; + temp: Integer; +begin + if (cinfo.progress = nil) or (cinfo.progress^.instance = nil) then Exit; + with cinfo.progress^ do + begin + Ticks := GetTickCount; + if (Ticks - last_time) < cinfo.progress^.instance.fProgressTime then Exit; + temp := last_time; + last_time := Ticks; + if temp = 0 then Exit; + if cinfo.is_decompressor then + with j_decompress_ptr(@cinfo)^ do + begin + R := MakeRect(0, last_scanline, output_width, output_scanline); + if R.Bottom < last_scanline then + R.Bottom := output_height; + end + else + R := MakeRect(0,0,0,0); + temp := Integer(Trunc(100.0*(completed_passes + (pass_counter/pass_limit))/total_passes)); + if temp = last_pct then Exit; + last_pct := temp; + if cinfo.is_decompressor then + last_scanline := j_decompress_ptr(@cinfo)^.output_scanline; + //instance.Progress(instance, psRunning, temp, (R.Bottom - R.Top) >= 4, R, ''); + if instance.FProgress( instance, R ) then + instance.FStop := TRUE; + end; +end; + +procedure ReleaseContext(var jc: TJPEGContext); +begin + if jc.common.err = nil then Exit; + jpeg_destroy(jc.common); + jc.common.err := nil; +end; + +procedure InitDecompressor(Obj: PJpeg; var jc: TJPEGContext); +begin + FillChar(jc, sizeof(jc), 0); + jc.err := jpeg_std_error; + jc.common.err := @jc.err; + + jpeg_CreateDecompress(jc.d, JPEG_LIB_VERSION, sizeof(jc.d)); + with Obj^ do + try + jc.progress.progress_monitor := FCallback; + jc.progress.instance := Obj; + jc.common.progress := @jc.progress; + + Obj.FImage.FData.Position := 0; + jpeg_stdio_src(jc.d, FImage.FData); + jpeg_read_header(jc.d, TRUE); + + jc.d.scale_num := 1; + jc.d.scale_denom := 1 shl Byte(FScale); + jc.d.do_block_smoothing := FSmoothing; + + if FGrayscale then jc.d.out_color_space := JCS_GRAYSCALE; + if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then + begin + jc.d.quantize_colors := True; + jc.d.desired_number_of_colors := 236; + end; + + if FPerformance = jpBestSpeed then + begin + jc.d.dct_method := JDCT_IFAST; + jc.d.two_pass_quantize := False; +// jc.d.do_fancy_upsampling := False; !! AV inside jpeglib + jc.d.dither_mode := JDITHER_ORDERED; + end; + + jc.FinalDCT := jc.d.dct_method; + jc.FinalTwoPassQuant := jc.d.two_pass_quantize; + jc.FinalDitherMode := jc.d.dither_mode; + if FProgressiveDisplay and jpeg_has_multiple_scans(jc.d) then + begin // save requested settings, reset for fastest on all but last scan + jc.d.enable_2pass_quant := jc.d.two_pass_quantize; + jc.d.dct_method := JDCT_IFAST; + jc.d.two_pass_quantize := False; + jc.d.dither_mode := JDITHER_ORDERED; + jc.d.buffered_image := True; + end; + except + ReleaseContext(jc); + raise; + end; +end; + +{ TJpeg } + +function DummyProgress( JPEGobj: PJpeg; const R: TRect ): Boolean; +begin + Result := FALSE; // not stop +end; + +function NormalProgress( JPEGobj: PJpeg; const R: TRect ): Boolean; +begin + Result := FALSE; // not stop + if Assigned( JPEGobj.FOnProgress ) then + JPEGobj.FOnProgress( JPEGobj, R, Result ); +end; + +function NewJpeg: PJpeg; +begin + new( Result, Create ); + with Result^ do + begin + CreateImage; + FQuality := JPEGDefaults.CompressionQuality; + FGrayscale := JPEGDefaults.Grayscale; + FPerformance := JPEGDefaults.Performance; + FPixelFormat := JPEGDefaults.PixelFormat; + FProgressiveDisplay := JPEGDefaults.ProgressiveDisplay; + FProgressiveEncoding := JPEGDefaults.ProgressiveEncoding; + FScale := JPEGDefaults.Scale; + FSmoothing := JPEGDefaults.Smoothing; + FProgress := DummyProgress; + FCallback := @ DummyProgressCallback; + fProgressTime := 100; + end; +end; + +procedure TJpeg.CalcOutputDimensions; +var + jc: TJPEGContext; +begin + if not FNeedRecalc then Exit; + InitDecompressor(@Self, jc); + try + jc.common.progress := nil; + jpeg_calc_output_dimensions(jc.d); + // read output dimensions + FScaledWidth := jc.d.output_width; + FScaledHeight := jc.d.output_height; + FProgressiveEncoding := jpeg_has_multiple_scans(jc.d); + finally + ReleaseContext(jc); + end; +end; + +procedure TJpeg.Clear; +begin + FreeBitmap; + FImage.Clear; +end; + +procedure TJpeg.Compress; +var + LinesWritten, LinesPerCall: Integer; + SrcScanLine: Pointer; + PtrInc: Integer; + jc: TJPEGContext; + Src: PBitmap; +begin + FillChar(jc, sizeof(jc), 0); + jc.err := jpeg_std_error; + jc.common.err := @jc.err; + + jpeg_CreateCompress(jc.c, JPEG_LIB_VERSION, sizeof(jc.c)); + try + try + jc.progress.progress_monitor := FCallback; + jc.progress.instance := @Self; + jc.common.progress := @jc.progress; + + if FImage.FData <> nil then CreateImage; + FImage.FData := NewMemoryStream; + FImage.FData.Position := 0; + jpeg_stdio_dest(jc.c, FImage.FData); + + if (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0) then Exit; + jc.c.image_width := FBitmap.Width; + FImage.FWidth := FBitmap.Width; + jc.c.image_height := FBitmap.Height; + FImage.FHeight := FBitmap.Height; + jc.c.input_components := 3; // JPEG requires 24bit RGB input + jc.c.in_color_space := JCS_RGB; + + Src := NewBitmap( 0, 0 ); + try + Src.Assign(FBitmap); + Src.PixelFormat := pf24bit; + + jpeg_set_defaults(jc.c); + jpeg_set_quality(jc.c, FQuality, True); + + if FGrayscale then + begin + FImage.FGrayscale := True; + jpeg_set_colorspace(jc.c, JCS_GRAYSCALE); + end; + + if ProgressiveEncoding then + jpeg_simple_progression(jc.c); + + SrcScanline := Src.ScanLine[0]; + PtrInc := 0; + //if jc.d.output_height > 1 then + if FImage.FHeight > 1 then + PtrInc := Integer(Src.ScanLine[1]) - Integer(SrcScanline); + + // if no dword padding required and source bitmap is top-down + if (PtrInc > 0) and ((PtrInc and 3) = 0) then + LinesPerCall := jc.c.image_height // do whole bitmap in one call + else + LinesPerCall := 1; // otherwise spoonfeed one row at a time + + //--Progress(Self, psStarting, 0, False, Rect(0,0,0,0), ''); + FProgress( @Self, MakeRect( 0, 0, 0, 0 ) ); + try + jpeg_start_compress(jc.c, True); + + while (jc.c.next_scanline < jc.c.image_height) do + begin + LinesWritten := jpeg_write_scanlines(jc.c, @SrcScanline, LinesPerCall); + Inc(Integer(SrcScanline), PtrInc * LinesWritten); + end; + + jpeg_finish_compress(jc.c); + finally + {-- + if ExceptObject = nil then + PtrInc := 100 + else + PtrInc := 0; + --} + //--Progress(Self, psEnding, PtrInc, False, Rect(0,0,0,0), ''); + //FProgress( @Self, MakeRect( 0, 0, 0, 0 ) ); + end; + finally + Src.Free; + end; + {$IFDEF JPEGERR} + except + //on EAbort do // OnProgress can raise EAbort to cancel image save + CreateImage; // Throw away any partial jpg data + {$ELSE} + finally {+} + {$ENDIF} + end; + finally + ReleaseContext(jc); + end; +end; + +destructor TJpeg.Destroy; +begin + if FTempPal <> 0 then DeleteObject(FTempPal); + FBitmap.Free; + FImage.Free; + inherited; +end; + +procedure TJpeg.DIBNeeded; +begin + GetBitmap; +end; + +procedure TJpeg.Draw(DC: HDC; X, Y: Integer); +begin + if Assigned(Bitmap) then + Bitmap.Draw( DC, X, Y ); +end; + +procedure TJpeg.FreeBitmap; +begin + FBitmap.Free; + FBitmap := nil; +end; + +function BuildPalette(const cinfo: jpeg_decompress_struct): HPalette; +var + Pal: TMaxLogPalette; + I: Integer; + C: Byte; +begin + Pal.palVersion := $300; + Pal.palNumEntries := cinfo.actual_number_of_colors; + if cinfo.out_color_space = JCS_GRAYSCALE then + for I := 0 to Pal.palNumEntries-1 do + begin + C := cinfo.colormap^[0]^[I]; + Pal.palPalEntry[I].peRed := C; + Pal.palPalEntry[I].peGreen := C; + Pal.palPalEntry[I].peBlue := C; + Pal.palPalEntry[I].peFlags := 0; + end + else + for I := 0 to Pal.palNumEntries-1 do + begin + Pal.palPalEntry[I].peRed := cinfo.colormap^[0]^[I]; + Pal.palPalEntry[I].peGreen := cinfo.colormap^[1]^[I]; + Pal.palPalEntry[I].peBlue := cinfo.colormap^[2]^[I]; + // 23 Jun 2005: R <-> B fixed (reporter: Sapersky) + Pal.palPalEntry[I].peFlags := 0; + end; + Result := CreatePalette(PLogPalette(@Pal)^); +end; + +procedure BuildColorMap(var cinfo: jpeg_decompress_struct; P: HPalette); +var + Pal: TMaxLogPalette; + Count, I: Integer; +begin + Count := GetPaletteEntries(P, 0, 256, Pal.palPalEntry); + if Count = 0 then Exit; // jpeg_destroy will free colormap + cinfo.colormap := cinfo.common.mem.alloc_sarray(@cinfo.common, JPOOL_IMAGE, Count, 3); + cinfo.actual_number_of_colors := Count; + for I := 0 to Count-1 do + begin + Byte(cinfo.colormap^[2]^[I]) := Pal.palPalEntry[I].peRed; + Byte(cinfo.colormap^[1]^[I]) := Pal.palPalEntry[I].peGreen; + Byte(cinfo.colormap^[0]^[I]) := Pal.palPalEntry[I].peBlue; + end; +end; + +procedure SetBitmapDIBPalette( Bmp: PBitmap; Pal: HPalette ); +var Entries: array[ 0..255 ] of Integer; + I: Integer; +begin + GetPaletteEntries( Pal, 0, 256, Entries[ 0 ] ); + for I := 0 to 255 do + Bmp.DIBPalEntries[ I ] := Entries[ I ]; +end; + +function TJpeg.GetBitmap: PBitmap; +var + LinesPerCall, LinesRead: Integer; + DestScanLine: Pointer; + PtrInc: Integer; + jc: TJPEGContext; + GeneratePalette: Boolean; + PaletteModified : Boolean; + + TmpPal: HPalette; + OK: Boolean; +begin + Result := FBitmap; + if Result <> nil then Exit; + + if (Width = 0) or (Height = 0) then + Exit; + GeneratePalette := True; + + {$IFNDEF JPEGERR} + Jpeg_Error := FALSE; + {$ENDIF} + FStop := FALSE; + InitDecompressor(@Self, jc); + {$IFNDEF JPEGERR} + FCorrupted := Jpeg_Error; + {$ENDIF} + + //++++++ + FBitmap.Free; + if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then + FBitmap := NewDIBBitmap( Width, Height, pf8bit ) + else + begin + if jc.d.out_color_space in [JCS_CMYK,JCS_YCCK] then + FBitmap := NewDIBBitmap( Width, Height, pf32bit ) + //jc.d.out_color_space := JCS_RGB; + else + FBitmap := NewDIBBitmap( Width, Height, pf24bit ); + end; + Result := FBitmap; + //++++++ + + + try + try + // Set the bitmap pixel format + + //--Progress(Self, psStarting, 0, False, Rect(0,0,0,0), ''); + FProgress( @Self, MakeRect( 0, 0, 0, 0 ) ); + PaletteModified := False; + OK := FALSE; + try + if (FTempPal <> 0) then + begin + if (FPixelFormat = jf8Bit) then + begin // Generate DIB using assigned palette + BuildColorMap(jc.d, FTempPal); + //-------------------------------------- + //FBitmap.Palette := CopyPalette(FTempPal); // Keep FTempPal around + //--------------------------------------- + SetBitmapDIBPalette( FBitmap, FTempPal ); + + GeneratePalette := False; + end + else + begin + DeleteObject(FTempPal); + FTempPal := 0; + end; + end; + + jpeg_start_decompress(jc.d); + //{$IFNDEF JPEGERR} + //if Jpeg_Error then Exit; + //{$ENDIF} + + // Set bitmap width and height + with FBitmap^ do + begin + //Handle := 0; + Width := jc.d.output_width; + Height := jc.d.output_height; + DestScanline := ScanLine[0]; + PtrInc := 0; + if jc.d.output_height > 1 then + PtrInc := Integer(ScanLine[1]) - Integer(DestScanline); + if (PtrInc > 0) and ((PtrInc and 3) = 0) then + // if no dword padding is required and output bitmap is top-down + LinesPerCall := jc.d.rec_outbuf_height // read multiple rows per call + else + LinesPerCall := 1; // otherwise read one row at a time + end; + + if jc.d.buffered_image then + begin // decode progressive scans at low quality, high speed + while jpeg_consume_input(jc.d) <> JPEG_REACHED_EOI do + begin + jpeg_start_output(jc.d, jc.d.input_scan_number); + {$IFNDEF JPEGERR} + if Jpeg_Error then Exit; + {$ENDIF} + if FStop then Exit; + // extract color palette + if (jc.common.progress^.completed_passes = 0) and (jc.d.colormap <> nil) + and (FBitmap.PixelFormat = pf8bit) and GeneratePalette then + begin + // + //FBitmap.Palette := BuildPalette(jc.d); + /////////////////////////////////////////// + TmpPal := BuildPalette(jc.d); // + SetBitmapDIBPalette( FBitmap, TmpPal ); // + DeleteObject( TmpPal ); // + /////////////////////////////////////////// + PaletteModified := True; + end; + DestScanLine := FBitmap.ScanLine[0]; + while (jc.d.output_scanline < jc.d.output_height) do + begin + LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall); + Inc(Integer(DestScanline), PtrInc * LinesRead); + end; + jpeg_finish_output(jc.d); + end; + // reset options for final pass at requested quality + jc.d.dct_method := jc.FinalDCT; + jc.d.dither_mode := jc.FinalDitherMode; + if jc.FinalTwoPassQuant then + begin + jc.d.two_pass_quantize := True; + jc.d.colormap := nil; + end; + jpeg_start_output(jc.d, jc.d.input_scan_number); + DestScanLine := FBitmap.ScanLine[0]; + end; + + // build final color palette + if (not jc.d.buffered_image or jc.FinalTwoPassQuant) and + (jc.d.colormap <> nil) and GeneratePalette then + begin + // + //FBitmap.Palette := BuildPalette(jc.d); + /////////////////////////////////////////// + TmpPal := BuildPalette(jc.d); // + SetBitmapDIBPalette( FBitmap, TmpPal ); // + DeleteObject( TmpPal ); // + /////////////////////////////////////////// + PaletteModified := True; + DestScanLine := FBitmap.ScanLine[0]; + end; + // final image pass for progressive, first and only pass for baseline + while (jc.d.output_scanline < jc.d.output_height) do + begin + LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall); + Inc(Integer(DestScanline), PtrInc * LinesRead); + end; + + if jc.d.buffered_image then jpeg_finish_output(jc.d); + jpeg_finish_decompress(jc.d); + OK := TRUE; + finally + {-- + if ExceptObject = nil then + PtrInc := 100 + else + PtrInc := 0; + --} + //--Progress(Self, psEnding, PtrInc, PaletteModified, Rect(0,0,0,0), ''); + FProgress( @Self, MakeRect( 0, 0, Width, Height ) ); + // Make sure new palette gets realized, in case OnProgress event didn't. + if PaletteModified then + Changed; + Jpeg_Error := Jpeg_Error or not OK; + if jc.d.out_color_space in [JCS_CMYK,JCS_YCCK] then + begin + FCMYK := TRUE; + if Assigned( FConvertCMYK2RGBProc ) then + begin + FConvertCMYK2RGBProc( FBitmap ); + FCMYK := FALSE; + end; + end; + end; + except + //--on EAbort do ; // OnProgress can raise EAbort to cancel image load + {$IFDEF JPEGERR} + FCorrupted := TRUE; + {$ENDIF} + end; + finally + ReleaseContext(jc); + {$IFNDEF JPEGERR} + FCorrupted := Jpeg_Error; + {$ENDIF} + end; +end; + +function TJpeg.GetEmpty: Boolean; +begin + Result := (Width = 0) or (Height = 0); + {Result := (FImage.FData = nil) and + ((FBitmap = nil) or FBitmap.Empty);} +end; + +function TJpeg.GetGrayscale: Boolean; +begin + Result := FGrayscale or FImage.FGrayscale; +end; + +function TJpeg.GetHeight: Integer; +begin + if FBitmap <> nil then + Result := FBitmap.Height + else + if FScale = jsFullSize then + Result := FImage.FHeight + else + begin + CalcOutputDimensions; + Result := FScaledHeight; + end; +end; + +function TJpeg.GetPalette: HPALETTE; +var DC: HDC; +begin + Result := 0; + {if FBitmap <> nil then + Result := FBitmap.Palette + else} if FTempPal <> 0 then + Result := FTempPal + else if FPixelFormat = jf24Bit then // check for 8 bit screen + begin + DC := GetDC(0); + if (GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <= 8 then + begin + FTempPal := CreateHalftonePalette(DC); + Result := FTempPal; + end; + ReleaseDC(0, DC); + end; +end; + +function TJpeg.GetWidth: Integer; +begin + if FBitmap <> nil then + Result := FBitmap.Width + else if FScale = jsFullSize then + Result := FImage.FWidth + else + begin + CalcOutputDimensions; + Result := FScaledWidth; + end; +end; + +procedure TJpeg.JPEGNeeded; +begin + if FImage.FData = nil then + Compress; +end; + +procedure TJpeg.LoadFromStream(Stream: PStream); +begin + FCorrupted := FALSE; + ReadStream(Stream.Size - Stream.Position, Stream); +end; + +procedure TJpeg.CreateBitmap; +begin + FBitmap.Free; + FBitmap := NewBitmap(0, 0); +end; + +procedure TJpeg.CreateImage; +begin + FImage.Free; + new( FImage, Create ); +end; + +procedure TJpeg.ReadData(Stream: PStream); +var Size: Integer; +begin + Stream.Read(Size, SizeOf(Size)); + ReadStream(Size, Stream); +end; + +procedure TJpeg.ReadStream(Size: Integer; Stream: PStream); +var + jerr: jpeg_error_mgr; + cinfo: jpeg_decompress_struct; +begin + CreateImage; + FreeBitmap; + try + with FImage^ do + begin + FData := NewMemoryStream; + FData.Size := Size; + Stream.Read(FData.Memory^, Size); + if Size > 0 {SizeOf(cinfo)} then + begin + jerr := jpeg_std_error; // use local var for thread isolation + cinfo.common.err := @jerr; + jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION, sizeof(cinfo)); + try + FData.Position := 0; + jpeg_stdio_src(cinfo, FData); + jpeg_read_header(cinfo, TRUE); + FWidth := cinfo.image_width; + FHeight := cinfo.image_height; + FGrayscale := cinfo.jpeg_color_space = JCS_GRAYSCALE; + FProgressiveEncoding := jpeg_has_multiple_scans(cinfo); + finally + jpeg_destroy_decompress(cinfo); + end; + end; + end; + //PaletteModified := True; + except + CreateImage; + //FreeBitmap; + end; + Changed; +end; + +procedure TJpeg.SaveToStream(Stream: PStream); +begin + JPEGNeeded; + with FImage.FData^ do + Stream.Write(Memory^, Size); +end; + +procedure TJpeg.SetGrayscale(Value: Boolean); +begin + if FGrayscale <> Value then + begin + FreeBitmap; + FGrayscale := Value; + //--PaletteModified := True; + Changed; + end; +end; + +procedure TJpeg.SetHeight(Value: Integer); +begin + InvalidOperation( 'Could not set height for JPEG image' ); +end; + +procedure TJpeg.SetPalette(Value: HPalette); +var SignalChange: Boolean; +begin + if Value <> FTempPal then + begin + SignalChange := (FBitmap <> nil); //and (Value <> FBitmap.Palette); + if SignalChange then FreeBitmap; + if FTempPal <> 0 then DeleteObject(FTempPal); + FTempPal := Value; + if SignalChange then + begin + //PaletteModified := True; + Changed; + end; + end; +end; + +procedure TJpeg.SetPerformance(Value: TJPEGPerformance); +begin + if FPerformance <> Value then + begin + FreeBitmap; + FPerformance := Value; + //--PaletteModified := True; + Changed; + end; +end; + +procedure TJpeg.SetPixelFormat(Value: TJPEGPixelFormat); +begin + if FPixelFormat <> Value then + begin + { + FreeBitmap; + FPixelFormat := Value; + //--PaletteModified := True; + Changed; + } + DIBNeeded; + FImage.FData.Free; + FImage.FData:= nil; + FPixelFormat := Value; + JPEGNeeded; + FreeBitmap; + Changed; + end; +end; + +procedure TJpeg.SetScale(Value: TJPEGScale); +begin + if FScale <> Value then + begin + FreeBitmap; + FScale := Value; + FNeedRecalc := True; + Changed; + end; +end; + +procedure TJpeg.SetSmoothing(Value: Boolean); +begin + if FSmoothing <> Value then + begin + FreeBitmap; + FSmoothing := Value; + Changed; + end; +end; + +procedure TJpeg.SetWidth(Value: Integer); +begin + InvalidOperation( 'Could not set width for JPEG image' ); +end; + +procedure TJpeg.StretchDraw(DC: HDC; Dest: TRect); +begin + Bitmap.StretchDraw( DC, Dest ); +end; + +procedure TJpeg.WriteData(Stream: PStream); +var + Size: Integer; +begin + Size := 0; + if Assigned(FImage.FData) then Size := FImage.FData.Size; + Stream.Write(Size, Sizeof(Size)); + if Size > 0 then Stream.Write(FImage.FData.Memory^, Size); +end; + +function TJpeg.LoadFromFile( const FName : String ) : Boolean; +var Strm : PStream; +begin + Clear; + Strm := NewReadFileStream( FName ); + if Strm.Size > 0 then + LoadFromStream( Strm ); + Strm.Free; + Result := not Empty; +end; + +function TJpeg.SaveToFile( const FName : String ) : Boolean; +var Strm : PStream; +begin + Result := False; + if Empty then Exit; + Strm := NewWriteFileStream( FName ); + SaveToStream( Strm ); + Result := Strm.Position > 0; + Strm.Free; +end; + +procedure TJpeg.Changed; +begin + if Assigned( OnChange ) then + OnChange( @Self ); +end; + +{function TJpeg.Empty: Boolean; +begin + Result := (Width = 0) or (Height = 0); +end;} + +procedure TJpeg.SetOnProgress(const Value: TJPEGProgress); +begin + FOnProgress := Value; + FProgress := NormalProgress; + FCallback := @ ProgressCallback; +end; + +procedure TJpeg.SetBitmap(const Value: PBitmap); +begin + CreateImage; + CreateBitmap; + {FBitmap :=} FBitmap.Assign( Value ); + Changed; +end; + +procedure DoConvertCMYK2RGB( Bmp: PBitmap ); +var I, J: Integer; + C, M, Y, K, R, G, B: Integer; + P: PDWORD; +begin + if Bmp.PixelFormat <> pf32bit then Exit; + for I := 0 to Bmp.Height-1 do + begin + P := Bmp.ScanLine[ I ]; + for J := 0 to Bmp.Width - 1 do + begin + C := P^ and $FF; + M := (P^ shr 8) and $FF; + Y := (P^ shr 16) and $FF; + K := P^ shr 24; + R := Y * K div 255; + G := M * K div 255; + B := C * K div 255; + P^ := R or (G shl 8) or (B shl 16); + Inc( P ); + end; + end; +end; + +procedure TJpeg.SetConvertCMYK2RGB(const Value: Boolean); +begin + FConvertCMYK2RGB := Value; + if TRUE then + begin + FConvertCMYK2RGBProc := DoConvertCMYK2RGB; + if (FBitmap <> nil) and FCMYK and + (FBitmap.Width > 0) and (FBitmap.Height > 0) then + DoConvertCMYK2RGB( FBitmap ); + end + else + begin + FConvertCMYK2RGBProc := nil; + end; +end; + +end. + diff --git a/Addons/KOLBlockCipher.pas b/Addons/KOLBlockCipher.pas new file mode 100644 index 0000000..2d44fec --- /dev/null +++ b/Addons/KOLBlockCipher.pas @@ -0,0 +1,7883 @@ +unit KOLBlockCipher; +{$A1} +interface + +uses Windows, Messages, KOL; + +type +// PBlockCipher64 = ^TBlockCipher64; + TBlockCipher64 = object(TObj) + protected + + IV, CV: array[0..7] of byte; + procedure IncCounter; + + public + // code + procedure InitKey(const Key; Size: longword);virtual; + + procedure Reset; + { Reset any stored chaining information } + procedure Burn;virtual; + { Clear all stored key information and chaining information } + procedure SetIV(const Value); + { Sets the IV to Value and performs a reset } + procedure GetIV(var Value); + { Returns the current chaining information, not the actual IV } + procedure InitBlockCipher64(const Key; Size: longword; InitVector: pointer); + { Do key setup based on the data in Key, size is in bits } + + procedure EncryptCBC(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CBC method of encryption } + procedure DecryptCBC(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CBC method of decryption } + procedure EncryptCFB8bit(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CFB (8 bit) method of encryption } + procedure DecryptCFB8bit(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CFB (8 bit) method of decryption } + procedure EncryptCFBblock(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CFB (block) method of encryption } + procedure DecryptCFBblock(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CFB (block) method of decryption } + procedure EncryptOFB(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the OFB method of encryption } + procedure DecryptOFB(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the OFB method of decryption } + procedure EncryptCTR(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CTR method of encryption } + procedure DecryptCTR(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CTR method of decryption } + procedure EncryptECB(const Indata; var Outdata);virtual; + { Override it! } + procedure DecryptECB(const Indata; var Outdata);virtual; + { Override it! } + + + destructor Destroy; virtual; + end; + +type +// PBlockCipher128 = ^TBlockCipher128; + TBlockCipher128 = object(TObj) + private + IV, CV: array[0..15] of byte; + + procedure IncCounter; + public + procedure InitKey(const Key; Size: longword);virtual; + + procedure Reset; + { Reset any stored chaining information } + procedure Burn; + { Clear all stored key information and chaining information } + procedure SetIV(const Value); + { Sets the IV to Value and performs a reset } + procedure GetIV(var Value); + { Returns the current chaining information, not the actual IV } + procedure InitBlockCipher128(const Key; Size: longword; InitVector: pointer); + { Do key setup based on the data in Key, size is in bits } + + procedure EncryptCBC(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CBC method of encryption } + procedure DecryptCBC(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CBC method of decryption } + procedure EncryptCFB8bit(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CFB (8 bit) method of encryption } + procedure DecryptCFB8bit(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CFB (8 bit) method of decryption } + procedure EncryptCFBblock(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CFB (block) method of encryption } + procedure DecryptCFBblock(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CFB (block) method of decryption } + procedure EncryptOFB(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the OFB method of encryption } + procedure DecryptOFB(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the OFB method of decryption } + procedure EncryptCTR(const Indata; var Outdata; Size: longword); + { Encrypt size bytes of data using the CTR method of encryption } + procedure DecryptCTR(const Indata; var Outdata; Size: longword); + { Decrypt size bytes of data using the CTR method of decryption } + + procedure EncryptECB(const Indata; var Outdata);virtual; + { Override it! } + procedure DecryptECB(const Indata; var Outdata);virtual; + { Override it! } + + destructor Destroy; virtual; + end; + +//Blowfish cipher implementation +const + PBoxOrg: array[0..17] of DWord= ( + $243f6a88, $85a308d3, $13198a2e, $03707344, + $a4093822, $299f31d0, $082efa98, $ec4e6c89, + $452821e6, $38d01377, $be5466cf, $34e90c6c, + $c0ac29b7, $c97c50dd, $3f84d5b5, $b5470917, + $9216d5d9, $8979fb1b); + SBoxOrg: array[0..3,0..255] of DWord= (( + $d1310ba6, $98dfb5ac, $2ffd72db, $d01adfb7, + $b8e1afed, $6a267e96, $ba7c9045, $f12c7f99, + $24a19947, $b3916cf7, $0801f2e2, $858efc16, + $636920d8, $71574e69, $a458fea3, $f4933d7e, + $0d95748f, $728eb658, $718bcd58, $82154aee, + $7b54a41d, $c25a59b5, $9c30d539, $2af26013, + $c5d1b023, $286085f0, $ca417918, $b8db38ef, + $8e79dcb0, $603a180e, $6c9e0e8b, $b01e8a3e, + $d71577c1, $bd314b27, $78af2fda, $55605c60, + $e65525f3, $aa55ab94, $57489862, $63e81440, + $55ca396a, $2aab10b6, $b4cc5c34, $1141e8ce, + $a15486af, $7c72e993, $b3ee1411, $636fbc2a, + $2ba9c55d, $741831f6, $ce5c3e16, $9b87931e, + $afd6ba33, $6c24cf5c, $7a325381, $28958677, + $3b8f4898, $6b4bb9af, $c4bfe81b, $66282193, + $61d809cc, $fb21a991, $487cac60, $5dec8032, + $ef845d5d, $e98575b1, $dc262302, $eb651b88, + $23893e81, $d396acc5, $0f6d6ff3, $83f44239, + $2e0b4482, $a4842004, $69c8f04a, $9e1f9b5e, + $21c66842, $f6e96c9a, $670c9c61, $abd388f0, + $6a51a0d2, $d8542f68, $960fa728, $ab5133a3, + $6eef0b6c, $137a3be4, $ba3bf050, $7efb2a98, + $a1f1651d, $39af0176, $66ca593e, $82430e88, + $8cee8619, $456f9fb4, $7d84a5c3, $3b8b5ebe, + $e06f75d8, $85c12073, $401a449f, $56c16aa6, + $4ed3aa62, $363f7706, $1bfedf72, $429b023d, + $37d0d724, $d00a1248, $db0fead3, $49f1c09b, + $075372c9, $80991b7b, $25d479d8, $f6e8def7, + $e3fe501a, $b6794c3b, $976ce0bd, $04c006ba, + $c1a94fb6, $409f60c4, $5e5c9ec2, $196a2463, + $68fb6faf, $3e6c53b5, $1339b2eb, $3b52ec6f, + $6dfc511f, $9b30952c, $cc814544, $af5ebd09, + $bee3d004, $de334afd, $660f2807, $192e4bb3, + $c0cba857, $45c8740f, $d20b5f39, $b9d3fbdb, + $5579c0bd, $1a60320a, $d6a100c6, $402c7279, + $679f25fe, $fb1fa3cc, $8ea5e9f8, $db3222f8, + $3c7516df, $fd616b15, $2f501ec8, $ad0552ab, + $323db5fa, $fd238760, $53317b48, $3e00df82, + $9e5c57bb, $ca6f8ca0, $1a87562e, $df1769db, + $d542a8f6, $287effc3, $ac6732c6, $8c4f5573, + $695b27b0, $bbca58c8, $e1ffa35d, $b8f011a0, + $10fa3d98, $fd2183b8, $4afcb56c, $2dd1d35b, + $9a53e479, $b6f84565, $d28e49bc, $4bfb9790, + $e1ddf2da, $a4cb7e33, $62fb1341, $cee4c6e8, + $ef20cada, $36774c01, $d07e9efe, $2bf11fb4, + $95dbda4d, $ae909198, $eaad8e71, $6b93d5a0, + $d08ed1d0, $afc725e0, $8e3c5b2f, $8e7594b7, + $8ff6e2fb, $f2122b64, $8888b812, $900df01c, + $4fad5ea0, $688fc31c, $d1cff191, $b3a8c1ad, + $2f2f2218, $be0e1777, $ea752dfe, $8b021fa1, + $e5a0cc0f, $b56f74e8, $18acf3d6, $ce89e299, + $b4a84fe0, $fd13e0b7, $7cc43b81, $d2ada8d9, + $165fa266, $80957705, $93cc7314, $211a1477, + $e6ad2065, $77b5fa86, $c75442f5, $fb9d35cf, + $ebcdaf0c, $7b3e89a0, $d6411bd3, $ae1e7e49, + $00250e2d, $2071b35e, $226800bb, $57b8e0af, + $2464369b, $f009b91e, $5563911d, $59dfa6aa, + $78c14389, $d95a537f, $207d5ba2, $02e5b9c5, + $83260376, $6295cfa9, $11c81968, $4e734a41, + $b3472dca, $7b14a94a, $1b510052, $9a532915, + $d60f573f, $bc9bc6e4, $2b60a476, $81e67400, + $08ba6fb5, $571be91f, $f296ec6b, $2a0dd915, + $b6636521, $e7b9f9b6, $ff34052e, $c5855664, + $53b02d5d, $a99f8fa1, $08ba4799, $6e85076a),( + $4b7a70e9, $b5b32944, $db75092e, $c4192623, + $ad6ea6b0, $49a7df7d, $9cee60b8, $8fedb266, + $ecaa8c71, $699a17ff, $5664526c, $c2b19ee1, + $193602a5, $75094c29, $a0591340, $e4183a3e, + $3f54989a, $5b429d65, $6b8fe4d6, $99f73fd6, + $a1d29c07, $efe830f5, $4d2d38e6, $f0255dc1, + $4cdd2086, $8470eb26, $6382e9c6, $021ecc5e, + $09686b3f, $3ebaefc9, $3c971814, $6b6a70a1, + $687f3584, $52a0e286, $b79c5305, $aa500737, + $3e07841c, $7fdeae5c, $8e7d44ec, $5716f2b8, + $b03ada37, $f0500c0d, $f01c1f04, $0200b3ff, + $ae0cf51a, $3cb574b2, $25837a58, $dc0921bd, + $d19113f9, $7ca92ff6, $94324773, $22f54701, + $3ae5e581, $37c2dadc, $c8b57634, $9af3dda7, + $a9446146, $0fd0030e, $ecc8c73e, $a4751e41, + $e238cd99, $3bea0e2f, $3280bba1, $183eb331, + $4e548b38, $4f6db908, $6f420d03, $f60a04bf, + $2cb81290, $24977c79, $5679b072, $bcaf89af, + $de9a771f, $d9930810, $b38bae12, $dccf3f2e, + $5512721f, $2e6b7124, $501adde6, $9f84cd87, + $7a584718, $7408da17, $bc9f9abc, $e94b7d8c, + $ec7aec3a, $db851dfa, $63094366, $c464c3d2, + $ef1c1847, $3215d908, $dd433b37, $24c2ba16, + $12a14d43, $2a65c451, $50940002, $133ae4dd, + $71dff89e, $10314e55, $81ac77d6, $5f11199b, + $043556f1, $d7a3c76b, $3c11183b, $5924a509, + $f28fe6ed, $97f1fbfa, $9ebabf2c, $1e153c6e, + $86e34570, $eae96fb1, $860e5e0a, $5a3e2ab3, + $771fe71c, $4e3d06fa, $2965dcb9, $99e71d0f, + $803e89d6, $5266c825, $2e4cc978, $9c10b36a, + $c6150eba, $94e2ea78, $a5fc3c53, $1e0a2df4, + $f2f74ea7, $361d2b3d, $1939260f, $19c27960, + $5223a708, $f71312b6, $ebadfe6e, $eac31f66, + $e3bc4595, $a67bc883, $b17f37d1, $018cff28, + $c332ddef, $be6c5aa5, $65582185, $68ab9802, + $eecea50f, $db2f953b, $2aef7dad, $5b6e2f84, + $1521b628, $29076170, $ecdd4775, $619f1510, + $13cca830, $eb61bd96, $0334fe1e, $aa0363cf, + $b5735c90, $4c70a239, $d59e9e0b, $cbaade14, + $eecc86bc, $60622ca7, $9cab5cab, $b2f3846e, + $648b1eaf, $19bdf0ca, $a02369b9, $655abb50, + $40685a32, $3c2ab4b3, $319ee9d5, $c021b8f7, + $9b540b19, $875fa099, $95f7997e, $623d7da8, + $f837889a, $97e32d77, $11ed935f, $16681281, + $0e358829, $c7e61fd6, $96dedfa1, $7858ba99, + $57f584a5, $1b227263, $9b83c3ff, $1ac24696, + $cdb30aeb, $532e3054, $8fd948e4, $6dbc3128, + $58ebf2ef, $34c6ffea, $fe28ed61, $ee7c3c73, + $5d4a14d9, $e864b7e3, $42105d14, $203e13e0, + $45eee2b6, $a3aaabea, $db6c4f15, $facb4fd0, + $c742f442, $ef6abbb5, $654f3b1d, $41cd2105, + $d81e799e, $86854dc7, $e44b476a, $3d816250, + $cf62a1f2, $5b8d2646, $fc8883a0, $c1c7b6a3, + $7f1524c3, $69cb7492, $47848a0b, $5692b285, + $095bbf00, $ad19489d, $1462b174, $23820e00, + $58428d2a, $0c55f5ea, $1dadf43e, $233f7061, + $3372f092, $8d937e41, $d65fecf1, $6c223bdb, + $7cde3759, $cbee7460, $4085f2a7, $ce77326e, + $a6078084, $19f8509e, $e8efd855, $61d99735, + $a969a7aa, $c50c06c2, $5a04abfc, $800bcadc, + $9e447a2e, $c3453484, $fdd56705, $0e1e9ec9, + $db73dbd3, $105588cd, $675fda79, $e3674340, + $c5c43465, $713e38d8, $3d28f89e, $f16dff20, + $153e21e7, $8fb03d4a, $e6e39f2b, $db83adf7),( + $e93d5a68, $948140f7, $f64c261c, $94692934, + $411520f7, $7602d4f7, $bcf46b2e, $d4a20068, + $d4082471, $3320f46a, $43b7d4b7, $500061af, + $1e39f62e, $97244546, $14214f74, $bf8b8840, + $4d95fc1d, $96b591af, $70f4ddd3, $66a02f45, + $bfbc09ec, $03bd9785, $7fac6dd0, $31cb8504, + $96eb27b3, $55fd3941, $da2547e6, $abca0a9a, + $28507825, $530429f4, $0a2c86da, $e9b66dfb, + $68dc1462, $d7486900, $680ec0a4, $27a18dee, + $4f3ffea2, $e887ad8c, $b58ce006, $7af4d6b6, + $aace1e7c, $d3375fec, $ce78a399, $406b2a42, + $20fe9e35, $d9f385b9, $ee39d7ab, $3b124e8b, + $1dc9faf7, $4b6d1856, $26a36631, $eae397b2, + $3a6efa74, $dd5b4332, $6841e7f7, $ca7820fb, + $fb0af54e, $d8feb397, $454056ac, $ba489527, + $55533a3a, $20838d87, $fe6ba9b7, $d096954b, + $55a867bc, $a1159a58, $cca92963, $99e1db33, + $a62a4a56, $3f3125f9, $5ef47e1c, $9029317c, + $fdf8e802, $04272f70, $80bb155c, $05282ce3, + $95c11548, $e4c66d22, $48c1133f, $c70f86dc, + $07f9c9ee, $41041f0f, $404779a4, $5d886e17, + $325f51eb, $d59bc0d1, $f2bcc18f, $41113564, + $257b7834, $602a9c60, $dff8e8a3, $1f636c1b, + $0e12b4c2, $02e1329e, $af664fd1, $cad18115, + $6b2395e0, $333e92e1, $3b240b62, $eebeb922, + $85b2a20e, $e6ba0d99, $de720c8c, $2da2f728, + $d0127845, $95b794fd, $647d0862, $e7ccf5f0, + $5449a36f, $877d48fa, $c39dfd27, $f33e8d1e, + $0a476341, $992eff74, $3a6f6eab, $f4f8fd37, + $a812dc60, $a1ebddf8, $991be14c, $db6e6b0d, + $c67b5510, $6d672c37, $2765d43b, $dcd0e804, + $f1290dc7, $cc00ffa3, $b5390f92, $690fed0b, + $667b9ffb, $cedb7d9c, $a091cf0b, $d9155ea3, + $bb132f88, $515bad24, $7b9479bf, $763bd6eb, + $37392eb3, $cc115979, $8026e297, $f42e312d, + $6842ada7, $c66a2b3b, $12754ccc, $782ef11c, + $6a124237, $b79251e7, $06a1bbe6, $4bfb6350, + $1a6b1018, $11caedfa, $3d25bdd8, $e2e1c3c9, + $44421659, $0a121386, $d90cec6e, $d5abea2a, + $64af674e, $da86a85f, $bebfe988, $64e4c3fe, + $9dbc8057, $f0f7c086, $60787bf8, $6003604d, + $d1fd8346, $f6381fb0, $7745ae04, $d736fccc, + $83426b33, $f01eab71, $b0804187, $3c005e5f, + $77a057be, $bde8ae24, $55464299, $bf582e61, + $4e58f48f, $f2ddfda2, $f474ef38, $8789bdc2, + $5366f9c3, $c8b38e74, $b475f255, $46fcd9b9, + $7aeb2661, $8b1ddf84, $846a0e79, $915f95e2, + $466e598e, $20b45770, $8cd55591, $c902de4c, + $b90bace1, $bb8205d0, $11a86248, $7574a99e, + $b77f19b6, $e0a9dc09, $662d09a1, $c4324633, + $e85a1f02, $09f0be8c, $4a99a025, $1d6efe10, + $1ab93d1d, $0ba5a4df, $a186f20f, $2868f169, + $dcb7da83, $573906fe, $a1e2ce9b, $4fcd7f52, + $50115e01, $a70683fa, $a002b5c4, $0de6d027, + $9af88c27, $773f8641, $c3604c06, $61a806b5, + $f0177a28, $c0f586e0, $006058aa, $30dc7d62, + $11e69ed7, $2338ea63, $53c2dd94, $c2c21634, + $bbcbee56, $90bcb6de, $ebfc7da1, $ce591d76, + $6f05e409, $4b7c0188, $39720a3d, $7c927c24, + $86e3725f, $724d9db9, $1ac15bb4, $d39eb8fc, + $ed545578, $08fca5b5, $d83d7cd3, $4dad0fc4, + $1e50ef5e, $b161e6f8, $a28514d9, $6c51133c, + $6fd5c7e7, $56e14ec4, $362abfce, $ddc6c837, + $d79a3234, $92638212, $670efa8e, $406000e0),( + $3a39ce37, $d3faf5cf, $abc27737, $5ac52d1b, + $5cb0679e, $4fa33742, $d3822740, $99bc9bbe, + $d5118e9d, $bf0f7315, $d62d1c7e, $c700c47b, + $b78c1b6b, $21a19045, $b26eb1be, $6a366eb4, + $5748ab2f, $bc946e79, $c6a376d2, $6549c2c8, + $530ff8ee, $468dde7d, $d5730a1d, $4cd04dc6, + $2939bbdb, $a9ba4650, $ac9526e8, $be5ee304, + $a1fad5f0, $6a2d519a, $63ef8ce2, $9a86ee22, + $c089c2b8, $43242ef6, $a51e03aa, $9cf2d0a4, + $83c061ba, $9be96a4d, $8fe51550, $ba645bd6, + $2826a2f9, $a73a3ae1, $4ba99586, $ef5562e9, + $c72fefd3, $f752f7da, $3f046f69, $77fa0a59, + $80e4a915, $87b08601, $9b09e6ad, $3b3ee593, + $e990fd5a, $9e34d797, $2cf0b7d9, $022b8b51, + $96d5ac3a, $017da67d, $d1cf3ed6, $7c7d2d28, + $1f9f25cf, $adf2b89b, $5ad6b472, $5a88f54c, + $e029ac71, $e019a5e6, $47b0acfd, $ed93fa9b, + $e8d3c48d, $283b57cc, $f8d56629, $79132e28, + $785f0191, $ed756055, $f7960e44, $e3d35e8c, + $15056dd4, $88f46dba, $03a16125, $0564f0bd, + $c3eb9e15, $3c9057a2, $97271aec, $a93a072a, + $1b3f6d9b, $1e6321f5, $f59c66fb, $26dcf319, + $7533d928, $b155fdf5, $03563482, $8aba3cbb, + $28517711, $c20ad9f8, $abcc5167, $ccad925f, + $4de81751, $3830dc8e, $379d5862, $9320f991, + $ea7a90c2, $fb3e7bce, $5121ce64, $774fbe32, + $a8b6e37e, $c3293d46, $48de5369, $6413e680, + $a2ae0810, $dd6db224, $69852dfd, $09072166, + $b39a460a, $6445c0dd, $586cdecf, $1c20c8ae, + $5bbef7dd, $1b588d40, $ccd2017f, $6bb4e3bb, + $dda26a7e, $3a59ff45, $3e350a44, $bcb4cdd5, + $72eacea8, $fa6484bb, $8d6612ae, $bf3c6f47, + $d29be463, $542f5d9e, $aec2771b, $f64e6370, + $740e0d8d, $e75b1357, $f8721671, $af537d5d, + $4040cb08, $4eb4e2cc, $34d2466a, $0115af84, + $e1b00428, $95983a1d, $06b89fb4, $ce6ea048, + $6f3f3b82, $3520ab82, $011a1d4b, $277227f8, + $611560b1, $e7933fdc, $bb3a792b, $344525bd, + $a08839e1, $51ce794b, $2f32c9b7, $a01fbac9, + $e01cc87e, $bcc7d1f6, $cf0111c3, $a1e8aac7, + $1a908749, $d44fbd9a, $d0dadecb, $d50ada38, + $0339c32a, $c6913667, $8df9317c, $e0b12b4f, + $f79e59b7, $43f5bb3a, $f2d519ff, $27d9459c, + $bf97222c, $15e6fc2a, $0f91fc71, $9b941525, + $fae59361, $ceb69ceb, $c2a86459, $12baa8d1, + $b6c1075e, $e3056a0c, $10d25065, $cb03a442, + $e0ec6e0e, $1698db3b, $4c98a0be, $3278e964, + $9f1f9532, $e0d392df, $d3a0342b, $8971f21e, + $1b0a7441, $4ba3348c, $c5be7120, $c37632d8, + $df359f8d, $9b992f2e, $e60b6f47, $0fe3f11d, + $e54cda54, $1edad891, $ce6279cf, $cd3e7e6f, + $1618b166, $fd2c1d05, $848fd2c5, $f6fb2299, + $f523f357, $a6327623, $93a83531, $56cccd02, + $acf08162, $5a75ebb5, $6e163697, $88d273cc, + $de966292, $81b949d0, $4c50901b, $71c65614, + $e6c6c7bd, $327a140a, $45e1d006, $c3f27b9a, + $c9aa53fd, $62a80f00, $bb25bfe2, $35bdd2f6, + $71126905, $b2040222, $b6cbcf7c, $cd769c2b, + $53113ec0, $1640e3d3, $38abbd60, $2547adf0, + $ba38209c, $f746ce76, $77afa1c5, $20756060, + $85cbfe4e, $8ae88dd8, $7aaaf9b0, $4cf9aa7e, + $1948c25c, $02fb8a8c, $01c36ae4, $d6ebe1f9, + $90d4f869, $a65cdea0, $3f09252d, $c208e69f, + $b74e6132, $ce77e25b, $578fdfe3, $3ac372e6)); + + +type + PByteArray = ^TByteArray; + TByteArray = array[0..32767] of Byte; + + +type + PBlowfish = ^TBlowfish; + TBlowfish = object(TBlockCipher64) + protected + SBox: array[0..3,0..255] of DWord; + PBox: array[0..17] of DWord; + public + + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + + destructor Destroy; virtual; + end; + +//Cast128 cipher implementation +const + cast_sbox1: array[0..255]of DWord= ( + $30FB40D4, $9FA0FF0B, $6BECCD2F, $3F258C7A, + $1E213F2F, $9C004DD3, $6003E540, $CF9FC949, + $BFD4AF27, $88BBBDB5, $E2034090, $98D09675, + $6E63A0E0, $15C361D2, $C2E7661D, $22D4FF8E, + $28683B6F, $C07FD059, $FF2379C8, $775F50E2, + $43C340D3, $DF2F8656, $887CA41A, $A2D2BD2D, + $A1C9E0D6, $346C4819, $61B76D87, $22540F2F, + $2ABE32E1, $AA54166B, $22568E3A, $A2D341D0, + $66DB40C8, $A784392F, $004DFF2F, $2DB9D2DE, + $97943FAC, $4A97C1D8, $527644B7, $B5F437A7, + $B82CBAEF, $D751D159, $6FF7F0ED, $5A097A1F, + $827B68D0, $90ECF52E, $22B0C054, $BC8E5935, + $4B6D2F7F, $50BB64A2, $D2664910, $BEE5812D, + $B7332290, $E93B159F, $B48EE411, $4BFF345D, + $FD45C240, $AD31973F, $C4F6D02E, $55FC8165, + $D5B1CAAD, $A1AC2DAE, $A2D4B76D, $C19B0C50, + $882240F2, $0C6E4F38, $A4E4BFD7, $4F5BA272, + $564C1D2F, $C59C5319, $B949E354, $B04669FE, + $B1B6AB8A, $C71358DD, $6385C545, $110F935D, + $57538AD5, $6A390493, $E63D37E0, $2A54F6B3, + $3A787D5F, $6276A0B5, $19A6FCDF, $7A42206A, + $29F9D4D5, $F61B1891, $BB72275E, $AA508167, + $38901091, $C6B505EB, $84C7CB8C, $2AD75A0F, + $874A1427, $A2D1936B, $2AD286AF, $AA56D291, + $D7894360, $425C750D, $93B39E26, $187184C9, + $6C00B32D, $73E2BB14, $A0BEBC3C, $54623779, + $64459EAB, $3F328B82, $7718CF82, $59A2CEA6, + $04EE002E, $89FE78E6, $3FAB0950, $325FF6C2, + $81383F05, $6963C5C8, $76CB5AD6, $D49974C9, + $CA180DCF, $380782D5, $C7FA5CF6, $8AC31511, + $35E79E13, $47DA91D0, $F40F9086, $A7E2419E, + $31366241, $051EF495, $AA573B04, $4A805D8D, + $548300D0, $00322A3C, $BF64CDDF, $BA57A68E, + $75C6372B, $50AFD341, $A7C13275, $915A0BF5, + $6B54BFAB, $2B0B1426, $AB4CC9D7, $449CCD82, + $F7FBF265, $AB85C5F3, $1B55DB94, $AAD4E324, + $CFA4BD3F, $2DEAA3E2, $9E204D02, $C8BD25AC, + $EADF55B3, $D5BD9E98, $E31231B2, $2AD5AD6C, + $954329DE, $ADBE4528, $D8710F69, $AA51C90F, + $AA786BF6, $22513F1E, $AA51A79B, $2AD344CC, + $7B5A41F0, $D37CFBAD, $1B069505, $41ECE491, + $B4C332E6, $032268D4, $C9600ACC, $CE387E6D, + $BF6BB16C, $6A70FB78, $0D03D9C9, $D4DF39DE, + $E01063DA, $4736F464, $5AD328D8, $B347CC96, + $75BB0FC3, $98511BFB, $4FFBCC35, $B58BCF6A, + $E11F0ABC, $BFC5FE4A, $A70AEC10, $AC39570A, + $3F04442F, $6188B153, $E0397A2E, $5727CB79, + $9CEB418F, $1CACD68D, $2AD37C96, $0175CB9D, + $C69DFF09, $C75B65F0, $D9DB40D8, $EC0E7779, + $4744EAD4, $B11C3274, $DD24CB9E, $7E1C54BD, + $F01144F9, $D2240EB1, $9675B3FD, $A3AC3755, + $D47C27AF, $51C85F4D, $56907596, $A5BB15E6, + $580304F0, $CA042CF1, $011A37EA, $8DBFAADB, + $35BA3E4A, $3526FFA0, $C37B4D09, $BC306ED9, + $98A52666, $5648F725, $FF5E569D, $0CED63D0, + $7C63B2CF, $700B45E1, $D5EA50F1, $85A92872, + $AF1FBDA7, $D4234870, $A7870BF3, $2D3B4D79, + $42E04198, $0CD0EDE7, $26470DB8, $F881814C, + $474D6AD7, $7C0C5E5C, $D1231959, $381B7298, + $F5D2F4DB, $AB838653, $6E2F1E23, $83719C9E, + $BD91E046, $9A56456E, $DC39200C, $20C8C571, + $962BDA1C, $E1E696FF, $B141AB08, $7CCA89B9, + $1A69E783, $02CC4843, $A2F7C579, $429EF47D, + $427B169C, $5AC9F049, $DD8F0F00, $5C8165BF + ); + + cast_sbox2: array[0..255] of DWord = ( + $1F201094, $EF0BA75B, $69E3CF7E, $393F4380, + $FE61CF7A, $EEC5207A, $55889C94, $72FC0651, + $ADA7EF79, $4E1D7235, $D55A63CE, $DE0436BA, + $99C430EF, $5F0C0794, $18DCDB7D, $A1D6EFF3, + $A0B52F7B, $59E83605, $EE15B094, $E9FFD909, + $DC440086, $EF944459, $BA83CCB3, $E0C3CDFB, + $D1DA4181, $3B092AB1, $F997F1C1, $A5E6CF7B, + $01420DDB, $E4E7EF5B, $25A1FF41, $E180F806, + $1FC41080, $179BEE7A, $D37AC6A9, $FE5830A4, + $98DE8B7F, $77E83F4E, $79929269, $24FA9F7B, + $E113C85B, $ACC40083, $D7503525, $F7EA615F, + $62143154, $0D554B63, $5D681121, $C866C359, + $3D63CF73, $CEE234C0, $D4D87E87, $5C672B21, + $071F6181, $39F7627F, $361E3084, $E4EB573B, + $602F64A4, $D63ACD9C, $1BBC4635, $9E81032D, + $2701F50C, $99847AB4, $A0E3DF79, $BA6CF38C, + $10843094, $2537A95E, $F46F6FFE, $A1FF3B1F, + $208CFB6A, $8F458C74, $D9E0A227, $4EC73A34, + $FC884F69, $3E4DE8DF, $EF0E0088, $3559648D, + $8A45388C, $1D804366, $721D9BFD, $A58684BB, + $E8256333, $844E8212, $128D8098, $FED33FB4, + $CE280AE1, $27E19BA5, $D5A6C252, $E49754BD, + $C5D655DD, $EB667064, $77840B4D, $A1B6A801, + $84DB26A9, $E0B56714, $21F043B7, $E5D05860, + $54F03084, $066FF472, $A31AA153, $DADC4755, + $B5625DBF, $68561BE6, $83CA6B94, $2D6ED23B, + $ECCF01DB, $A6D3D0BA, $B6803D5C, $AF77A709, + $33B4A34C, $397BC8D6, $5EE22B95, $5F0E5304, + $81ED6F61, $20E74364, $B45E1378, $DE18639B, + $881CA122, $B96726D1, $8049A7E8, $22B7DA7B, + $5E552D25, $5272D237, $79D2951C, $C60D894C, + $488CB402, $1BA4FE5B, $A4B09F6B, $1CA815CF, + $A20C3005, $8871DF63, $B9DE2FCB, $0CC6C9E9, + $0BEEFF53, $E3214517, $B4542835, $9F63293C, + $EE41E729, $6E1D2D7C, $50045286, $1E6685F3, + $F33401C6, $30A22C95, $31A70850, $60930F13, + $73F98417, $A1269859, $EC645C44, $52C877A9, + $CDFF33A6, $A02B1741, $7CBAD9A2, $2180036F, + $50D99C08, $CB3F4861, $C26BD765, $64A3F6AB, + $80342676, $25A75E7B, $E4E6D1FC, $20C710E6, + $CDF0B680, $17844D3B, $31EEF84D, $7E0824E4, + $2CCB49EB, $846A3BAE, $8FF77888, $EE5D60F6, + $7AF75673, $2FDD5CDB, $A11631C1, $30F66F43, + $B3FAEC54, $157FD7FA, $EF8579CC, $D152DE58, + $DB2FFD5E, $8F32CE19, $306AF97A, $02F03EF8, + $99319AD5, $C242FA0F, $A7E3EBB0, $C68E4906, + $B8DA230C, $80823028, $DCDEF3C8, $D35FB171, + $088A1BC8, $BEC0C560, $61A3C9E8, $BCA8F54D, + $C72FEFFA, $22822E99, $82C570B4, $D8D94E89, + $8B1C34BC, $301E16E6, $273BE979, $B0FFEAA6, + $61D9B8C6, $00B24869, $B7FFCE3F, $08DC283B, + $43DAF65A, $F7E19798, $7619B72F, $8F1C9BA4, + $DC8637A0, $16A7D3B1, $9FC393B7, $A7136EEB, + $C6BCC63E, $1A513742, $EF6828BC, $520365D6, + $2D6A77AB, $3527ED4B, $821FD216, $095C6E2E, + $DB92F2FB, $5EEA29CB, $145892F5, $91584F7F, + $5483697B, $2667A8CC, $85196048, $8C4BACEA, + $833860D4, $0D23E0F9, $6C387E8A, $0AE6D249, + $B284600C, $D835731D, $DCB1C647, $AC4C56EA, + $3EBD81B3, $230EABB0, $6438BC87, $F0B5B1FA, + $8F5EA2B3, $FC184642, $0A036B7A, $4FB089BD, + $649DA589, $A345415E, $5C038323, $3E5D3BB9, + $43D79572, $7E6DD07C, $06DFDF1E, $6C6CC4EF, + $7160A539, $73BFBE70, $83877605, $4523ECF1 + ); + + cast_sbox3: array[0..255] of DWord = ( + $8DEFC240, $25FA5D9F, $EB903DBF, $E810C907, + $47607FFF, $369FE44B, $8C1FC644, $AECECA90, + $BEB1F9BF, $EEFBCAEA, $E8CF1950, $51DF07AE, + $920E8806, $F0AD0548, $E13C8D83, $927010D5, + $11107D9F, $07647DB9, $B2E3E4D4, $3D4F285E, + $B9AFA820, $FADE82E0, $A067268B, $8272792E, + $553FB2C0, $489AE22B, $D4EF9794, $125E3FBC, + $21FFFCEE, $825B1BFD, $9255C5ED, $1257A240, + $4E1A8302, $BAE07FFF, $528246E7, $8E57140E, + $3373F7BF, $8C9F8188, $A6FC4EE8, $C982B5A5, + $A8C01DB7, $579FC264, $67094F31, $F2BD3F5F, + $40FFF7C1, $1FB78DFC, $8E6BD2C1, $437BE59B, + $99B03DBF, $B5DBC64B, $638DC0E6, $55819D99, + $A197C81C, $4A012D6E, $C5884A28, $CCC36F71, + $B843C213, $6C0743F1, $8309893C, $0FEDDD5F, + $2F7FE850, $D7C07F7E, $02507FBF, $5AFB9A04, + $A747D2D0, $1651192E, $AF70BF3E, $58C31380, + $5F98302E, $727CC3C4, $0A0FB402, $0F7FEF82, + $8C96FDAD, $5D2C2AAE, $8EE99A49, $50DA88B8, + $8427F4A0, $1EAC5790, $796FB449, $8252DC15, + $EFBD7D9B, $A672597D, $ADA840D8, $45F54504, + $FA5D7403, $E83EC305, $4F91751A, $925669C2, + $23EFE941, $A903F12E, $60270DF2, $0276E4B6, + $94FD6574, $927985B2, $8276DBCB, $02778176, + $F8AF918D, $4E48F79E, $8F616DDF, $E29D840E, + $842F7D83, $340CE5C8, $96BBB682, $93B4B148, + $EF303CAB, $984FAF28, $779FAF9B, $92DC560D, + $224D1E20, $8437AA88, $7D29DC96, $2756D3DC, + $8B907CEE, $B51FD240, $E7C07CE3, $E566B4A1, + $C3E9615E, $3CF8209D, $6094D1E3, $CD9CA341, + $5C76460E, $00EA983B, $D4D67881, $FD47572C, + $F76CEDD9, $BDA8229C, $127DADAA, $438A074E, + $1F97C090, $081BDB8A, $93A07EBE, $B938CA15, + $97B03CFF, $3DC2C0F8, $8D1AB2EC, $64380E51, + $68CC7BFB, $D90F2788, $12490181, $5DE5FFD4, + $DD7EF86A, $76A2E214, $B9A40368, $925D958F, + $4B39FFFA, $BA39AEE9, $A4FFD30B, $FAF7933B, + $6D498623, $193CBCFA, $27627545, $825CF47A, + $61BD8BA0, $D11E42D1, $CEAD04F4, $127EA392, + $10428DB7, $8272A972, $9270C4A8, $127DE50B, + $285BA1C8, $3C62F44F, $35C0EAA5, $E805D231, + $428929FB, $B4FCDF82, $4FB66A53, $0E7DC15B, + $1F081FAB, $108618AE, $FCFD086D, $F9FF2889, + $694BCC11, $236A5CAE, $12DECA4D, $2C3F8CC5, + $D2D02DFE, $F8EF5896, $E4CF52DA, $95155B67, + $494A488C, $B9B6A80C, $5C8F82BC, $89D36B45, + $3A609437, $EC00C9A9, $44715253, $0A874B49, + $D773BC40, $7C34671C, $02717EF6, $4FEB5536, + $A2D02FFF, $D2BF60C4, $D43F03C0, $50B4EF6D, + $07478CD1, $006E1888, $A2E53F55, $B9E6D4BC, + $A2048016, $97573833, $D7207D67, $DE0F8F3D, + $72F87B33, $ABCC4F33, $7688C55D, $7B00A6B0, + $947B0001, $570075D2, $F9BB88F8, $8942019E, + $4264A5FF, $856302E0, $72DBD92B, $EE971B69, + $6EA22FDE, $5F08AE2B, $AF7A616D, $E5C98767, + $CF1FEBD2, $61EFC8C2, $F1AC2571, $CC8239C2, + $67214CB8, $B1E583D1, $B7DC3E62, $7F10BDCE, + $F90A5C38, $0FF0443D, $606E6DC6, $60543A49, + $5727C148, $2BE98A1D, $8AB41738, $20E1BE24, + $AF96DA0F, $68458425, $99833BE5, $600D457D, + $282F9350, $8334B362, $D91D1120, $2B6D8DA0, + $642B1E31, $9C305A00, $52BCE688, $1B03588A, + $F7BAEFD5, $4142ED9C, $A4315C11, $83323EC5, + $DFEF4636, $A133C501, $E9D3531C, $EE353783 + ); + + cast_sbox4: array[0..255] of DWord = ( + $9DB30420, $1FB6E9DE, $A7BE7BEF, $D273A298, + $4A4F7BDB, $64AD8C57, $85510443, $FA020ED1, + $7E287AFF, $E60FB663, $095F35A1, $79EBF120, + $FD059D43, $6497B7B1, $F3641F63, $241E4ADF, + $28147F5F, $4FA2B8CD, $C9430040, $0CC32220, + $FDD30B30, $C0A5374F, $1D2D00D9, $24147B15, + $EE4D111A, $0FCA5167, $71FF904C, $2D195FFE, + $1A05645F, $0C13FEFE, $081B08CA, $05170121, + $80530100, $E83E5EFE, $AC9AF4F8, $7FE72701, + $D2B8EE5F, $06DF4261, $BB9E9B8A, $7293EA25, + $CE84FFDF, $F5718801, $3DD64B04, $A26F263B, + $7ED48400, $547EEBE6, $446D4CA0, $6CF3D6F5, + $2649ABDF, $AEA0C7F5, $36338CC1, $503F7E93, + $D3772061, $11B638E1, $72500E03, $F80EB2BB, + $ABE0502E, $EC8D77DE, $57971E81, $E14F6746, + $C9335400, $6920318F, $081DBB99, $FFC304A5, + $4D351805, $7F3D5CE3, $A6C866C6, $5D5BCCA9, + $DAEC6FEA, $9F926F91, $9F46222F, $3991467D, + $A5BF6D8E, $1143C44F, $43958302, $D0214EEB, + $022083B8, $3FB6180C, $18F8931E, $281658E6, + $26486E3E, $8BD78A70, $7477E4C1, $B506E07C, + $F32D0A25, $79098B02, $E4EABB81, $28123B23, + $69DEAD38, $1574CA16, $DF871B62, $211C40B7, + $A51A9EF9, $0014377B, $041E8AC8, $09114003, + $BD59E4D2, $E3D156D5, $4FE876D5, $2F91A340, + $557BE8DE, $00EAE4A7, $0CE5C2EC, $4DB4BBA6, + $E756BDFF, $DD3369AC, $EC17B035, $06572327, + $99AFC8B0, $56C8C391, $6B65811C, $5E146119, + $6E85CB75, $BE07C002, $C2325577, $893FF4EC, + $5BBFC92D, $D0EC3B25, $B7801AB7, $8D6D3B24, + $20C763EF, $C366A5FC, $9C382880, $0ACE3205, + $AAC9548A, $ECA1D7C7, $041AFA32, $1D16625A, + $6701902C, $9B757A54, $31D477F7, $9126B031, + $36CC6FDB, $C70B8B46, $D9E66A48, $56E55A79, + $026A4CEB, $52437EFF, $2F8F76B4, $0DF980A5, + $8674CDE3, $EDDA04EB, $17A9BE04, $2C18F4DF, + $B7747F9D, $AB2AF7B4, $EFC34D20, $2E096B7C, + $1741A254, $E5B6A035, $213D42F6, $2C1C7C26, + $61C2F50F, $6552DAF9, $D2C231F8, $25130F69, + $D8167FA2, $0418F2C8, $001A96A6, $0D1526AB, + $63315C21, $5E0A72EC, $49BAFEFD, $187908D9, + $8D0DBD86, $311170A7, $3E9B640C, $CC3E10D7, + $D5CAD3B6, $0CAEC388, $F73001E1, $6C728AFF, + $71EAE2A1, $1F9AF36E, $CFCBD12F, $C1DE8417, + $AC07BE6B, $CB44A1D8, $8B9B0F56, $013988C3, + $B1C52FCA, $B4BE31CD, $D8782806, $12A3A4E2, + $6F7DE532, $58FD7EB6, $D01EE900, $24ADFFC2, + $F4990FC5, $9711AAC5, $001D7B95, $82E5E7D2, + $109873F6, $00613096, $C32D9521, $ADA121FF, + $29908415, $7FBB977F, $AF9EB3DB, $29C9ED2A, + $5CE2A465, $A730F32C, $D0AA3FE8, $8A5CC091, + $D49E2CE7, $0CE454A9, $D60ACD86, $015F1919, + $77079103, $DEA03AF6, $78A8565E, $DEE356DF, + $21F05CBE, $8B75E387, $B3C50651, $B8A5C3EF, + $D8EEB6D2, $E523BE77, $C2154529, $2F69EFDF, + $AFE67AFB, $F470C4B2, $F3E0EB5B, $D6CC9876, + $39E4460C, $1FDA8538, $1987832F, $CA007367, + $A99144F8, $296B299E, $492FC295, $9266BEAB, + $B5676E69, $9BD3DDDA, $DF7E052F, $DB25701C, + $1B5E51EE, $F65324E6, $6AFCE36C, $0316CC04, + $8644213E, $B7DC59D0, $7965291F, $CCD6FD43, + $41823979, $932BCDF6, $B657C34D, $4EDFD282, + $7AE5290C, $3CB9536B, $851E20FE, $9833557E, + $13ECF0B0, $D3FFB372, $3F85C5C1, $0AEF7ED2 + ); + + cast_sbox5: array[0..255] of DWord = ( + $7EC90C04, $2C6E74B9, $9B0E66DF, $A6337911, + $B86A7FFF, $1DD358F5, $44DD9D44, $1731167F, + $08FBF1FA, $E7F511CC, $D2051B00, $735ABA00, + $2AB722D8, $386381CB, $ACF6243A, $69BEFD7A, + $E6A2E77F, $F0C720CD, $C4494816, $CCF5C180, + $38851640, $15B0A848, $E68B18CB, $4CAADEFF, + $5F480A01, $0412B2AA, $259814FC, $41D0EFE2, + $4E40B48D, $248EB6FB, $8DBA1CFE, $41A99B02, + $1A550A04, $BA8F65CB, $7251F4E7, $95A51725, + $C106ECD7, $97A5980A, $C539B9AA, $4D79FE6A, + $F2F3F763, $68AF8040, $ED0C9E56, $11B4958B, + $E1EB5A88, $8709E6B0, $D7E07156, $4E29FEA7, + $6366E52D, $02D1C000, $C4AC8E05, $9377F571, + $0C05372A, $578535F2, $2261BE02, $D642A0C9, + $DF13A280, $74B55BD2, $682199C0, $D421E5EC, + $53FB3CE8, $C8ADEDB3, $28A87FC9, $3D959981, + $5C1FF900, $FE38D399, $0C4EFF0B, $062407EA, + $AA2F4FB1, $4FB96976, $90C79505, $B0A8A774, + $EF55A1FF, $E59CA2C2, $A6B62D27, $E66A4263, + $DF65001F, $0EC50966, $DFDD55BC, $29DE0655, + $911E739A, $17AF8975, $32C7911C, $89F89468, + $0D01E980, $524755F4, $03B63CC9, $0CC844B2, + $BCF3F0AA, $87AC36E9, $E53A7426, $01B3D82B, + $1A9E7449, $64EE2D7E, $CDDBB1DA, $01C94910, + $B868BF80, $0D26F3FD, $9342EDE7, $04A5C284, + $636737B6, $50F5B616, $F24766E3, $8ECA36C1, + $136E05DB, $FEF18391, $FB887A37, $D6E7F7D4, + $C7FB7DC9, $3063FCDF, $B6F589DE, $EC2941DA, + $26E46695, $B7566419, $F654EFC5, $D08D58B7, + $48925401, $C1BACB7F, $E5FF550F, $B6083049, + $5BB5D0E8, $87D72E5A, $AB6A6EE1, $223A66CE, + $C62BF3CD, $9E0885F9, $68CB3E47, $086C010F, + $A21DE820, $D18B69DE, $F3F65777, $FA02C3F6, + $407EDAC3, $CBB3D550, $1793084D, $B0D70EBA, + $0AB378D5, $D951FB0C, $DED7DA56, $4124BBE4, + $94CA0B56, $0F5755D1, $E0E1E56E, $6184B5BE, + $580A249F, $94F74BC0, $E327888E, $9F7B5561, + $C3DC0280, $05687715, $646C6BD7, $44904DB3, + $66B4F0A3, $C0F1648A, $697ED5AF, $49E92FF6, + $309E374F, $2CB6356A, $85808573, $4991F840, + $76F0AE02, $083BE84D, $28421C9A, $44489406, + $736E4CB8, $C1092910, $8BC95FC6, $7D869CF4, + $134F616F, $2E77118D, $B31B2BE1, $AA90B472, + $3CA5D717, $7D161BBA, $9CAD9010, $AF462BA2, + $9FE459D2, $45D34559, $D9F2DA13, $DBC65487, + $F3E4F94E, $176D486F, $097C13EA, $631DA5C7, + $445F7382, $175683F4, $CDC66A97, $70BE0288, + $B3CDCF72, $6E5DD2F3, $20936079, $459B80A5, + $BE60E2DB, $A9C23101, $EBA5315C, $224E42F2, + $1C5C1572, $F6721B2C, $1AD2FFF3, $8C25404E, + $324ED72F, $4067B7FD, $0523138E, $5CA3BC78, + $DC0FD66E, $75922283, $784D6B17, $58EBB16E, + $44094F85, $3F481D87, $FCFEAE7B, $77B5FF76, + $8C2302BF, $AAF47556, $5F46B02A, $2B092801, + $3D38F5F7, $0CA81F36, $52AF4A8A, $66D5E7C0, + $DF3B0874, $95055110, $1B5AD7A8, $F61ED5AD, + $6CF6E479, $20758184, $D0CEFA65, $88F7BE58, + $4A046826, $0FF6F8F3, $A09C7F70, $5346ABA0, + $5CE96C28, $E176EDA3, $6BAC307F, $376829D2, + $85360FA9, $17E3FE2A, $24B79767, $F5A96B20, + $D6CD2595, $68FF1EBF, $7555442C, $F19F06BE, + $F9E0659A, $EEB9491D, $34010718, $BB30CAB8, + $E822FE15, $88570983, $750E6249, $DA627E55, + $5E76FFA8, $B1534546, $6D47DE08, $EFE9E7D4 + ); + + cast_sbox6: array[0..255] of DWord = ( + $F6FA8F9D, $2CAC6CE1, $4CA34867, $E2337F7C, + $95DB08E7, $016843B4, $ECED5CBC, $325553AC, + $BF9F0960, $DFA1E2ED, $83F0579D, $63ED86B9, + $1AB6A6B8, $DE5EBE39, $F38FF732, $8989B138, + $33F14961, $C01937BD, $F506C6DA, $E4625E7E, + $A308EA99, $4E23E33C, $79CBD7CC, $48A14367, + $A3149619, $FEC94BD5, $A114174A, $EAA01866, + $A084DB2D, $09A8486F, $A888614A, $2900AF98, + $01665991, $E1992863, $C8F30C60, $2E78EF3C, + $D0D51932, $CF0FEC14, $F7CA07D2, $D0A82072, + $FD41197E, $9305A6B0, $E86BE3DA, $74BED3CD, + $372DA53C, $4C7F4448, $DAB5D440, $6DBA0EC3, + $083919A7, $9FBAEED9, $49DBCFB0, $4E670C53, + $5C3D9C01, $64BDB941, $2C0E636A, $BA7DD9CD, + $EA6F7388, $E70BC762, $35F29ADB, $5C4CDD8D, + $F0D48D8C, $B88153E2, $08A19866, $1AE2EAC8, + $284CAF89, $AA928223, $9334BE53, $3B3A21BF, + $16434BE3, $9AEA3906, $EFE8C36E, $F890CDD9, + $80226DAE, $C340A4A3, $DF7E9C09, $A694A807, + $5B7C5ECC, $221DB3A6, $9A69A02F, $68818A54, + $CEB2296F, $53C0843A, $FE893655, $25BFE68A, + $B4628ABC, $CF222EBF, $25AC6F48, $A9A99387, + $53BDDB65, $E76FFBE7, $E967FD78, $0BA93563, + $8E342BC1, $E8A11BE9, $4980740D, $C8087DFC, + $8DE4BF99, $A11101A0, $7FD37975, $DA5A26C0, + $E81F994F, $9528CD89, $FD339FED, $B87834BF, + $5F04456D, $22258698, $C9C4C83B, $2DC156BE, + $4F628DAA, $57F55EC5, $E2220ABE, $D2916EBF, + $4EC75B95, $24F2C3C0, $42D15D99, $CD0D7FA0, + $7B6E27FF, $A8DC8AF0, $7345C106, $F41E232F, + $35162386, $E6EA8926, $3333B094, $157EC6F2, + $372B74AF, $692573E4, $E9A9D848, $F3160289, + $3A62EF1D, $A787E238, $F3A5F676, $74364853, + $20951063, $4576698D, $B6FAD407, $592AF950, + $36F73523, $4CFB6E87, $7DA4CEC0, $6C152DAA, + $CB0396A8, $C50DFE5D, $FCD707AB, $0921C42F, + $89DFF0BB, $5FE2BE78, $448F4F33, $754613C9, + $2B05D08D, $48B9D585, $DC049441, $C8098F9B, + $7DEDE786, $C39A3373, $42410005, $6A091751, + $0EF3C8A6, $890072D6, $28207682, $A9A9F7BE, + $BF32679D, $D45B5B75, $B353FD00, $CBB0E358, + $830F220A, $1F8FB214, $D372CF08, $CC3C4A13, + $8CF63166, $061C87BE, $88C98F88, $6062E397, + $47CF8E7A, $B6C85283, $3CC2ACFB, $3FC06976, + $4E8F0252, $64D8314D, $DA3870E3, $1E665459, + $C10908F0, $513021A5, $6C5B68B7, $822F8AA0, + $3007CD3E, $74719EEF, $DC872681, $073340D4, + $7E432FD9, $0C5EC241, $8809286C, $F592D891, + $08A930F6, $957EF305, $B7FBFFBD, $C266E96F, + $6FE4AC98, $B173ECC0, $BC60B42A, $953498DA, + $FBA1AE12, $2D4BD736, $0F25FAAB, $A4F3FCEB, + $E2969123, $257F0C3D, $9348AF49, $361400BC, + $E8816F4A, $3814F200, $A3F94043, $9C7A54C2, + $BC704F57, $DA41E7F9, $C25AD33A, $54F4A084, + $B17F5505, $59357CBE, $EDBD15C8, $7F97C5AB, + $BA5AC7B5, $B6F6DEAF, $3A479C3A, $5302DA25, + $653D7E6A, $54268D49, $51A477EA, $5017D55B, + $D7D25D88, $44136C76, $0404A8C8, $B8E5A121, + $B81A928A, $60ED5869, $97C55B96, $EAEC991B, + $29935913, $01FDB7F1, $088E8DFA, $9AB6F6F5, + $3B4CBF9F, $4A5DE3AB, $E6051D35, $A0E1D855, + $D36B4CF1, $F544EDEB, $B0E93524, $BEBB8FBD, + $A2D762CF, $49C92F54, $38B5F331, $7128A454, + $48392905, $A65B1DB8, $851C97BD, $D675CF2F + ); + + cast_sbox7: array[0..255] of DWord = ( + $85E04019, $332BF567, $662DBFFF, $CFC65693, + $2A8D7F6F, $AB9BC912, $DE6008A1, $2028DA1F, + $0227BCE7, $4D642916, $18FAC300, $50F18B82, + $2CB2CB11, $B232E75C, $4B3695F2, $B28707DE, + $A05FBCF6, $CD4181E9, $E150210C, $E24EF1BD, + $B168C381, $FDE4E789, $5C79B0D8, $1E8BFD43, + $4D495001, $38BE4341, $913CEE1D, $92A79C3F, + $089766BE, $BAEEADF4, $1286BECF, $B6EACB19, + $2660C200, $7565BDE4, $64241F7A, $8248DCA9, + $C3B3AD66, $28136086, $0BD8DFA8, $356D1CF2, + $107789BE, $B3B2E9CE, $0502AA8F, $0BC0351E, + $166BF52A, $EB12FF82, $E3486911, $D34D7516, + $4E7B3AFF, $5F43671B, $9CF6E037, $4981AC83, + $334266CE, $8C9341B7, $D0D854C0, $CB3A6C88, + $47BC2829, $4725BA37, $A66AD22B, $7AD61F1E, + $0C5CBAFA, $4437F107, $B6E79962, $42D2D816, + $0A961288, $E1A5C06E, $13749E67, $72FC081A, + $B1D139F7, $F9583745, $CF19DF58, $BEC3F756, + $C06EBA30, $07211B24, $45C28829, $C95E317F, + $BC8EC511, $38BC46E9, $C6E6FA14, $BAE8584A, + $AD4EBC46, $468F508B, $7829435F, $F124183B, + $821DBA9F, $AFF60FF4, $EA2C4E6D, $16E39264, + $92544A8B, $009B4FC3, $ABA68CED, $9AC96F78, + $06A5B79A, $B2856E6E, $1AEC3CA9, $BE838688, + $0E0804E9, $55F1BE56, $E7E5363B, $B3A1F25D, + $F7DEBB85, $61FE033C, $16746233, $3C034C28, + $DA6D0C74, $79AAC56C, $3CE4E1AD, $51F0C802, + $98F8F35A, $1626A49F, $EED82B29, $1D382FE3, + $0C4FB99A, $BB325778, $3EC6D97B, $6E77A6A9, + $CB658B5C, $D45230C7, $2BD1408B, $60C03EB7, + $B9068D78, $A33754F4, $F430C87D, $C8A71302, + $B96D8C32, $EBD4E7BE, $BE8B9D2D, $7979FB06, + $E7225308, $8B75CF77, $11EF8DA4, $E083C858, + $8D6B786F, $5A6317A6, $FA5CF7A0, $5DDA0033, + $F28EBFB0, $F5B9C310, $A0EAC280, $08B9767A, + $A3D9D2B0, $79D34217, $021A718D, $9AC6336A, + $2711FD60, $438050E3, $069908A8, $3D7FEDC4, + $826D2BEF, $4EEB8476, $488DCF25, $36C9D566, + $28E74E41, $C2610ACA, $3D49A9CF, $BAE3B9DF, + $B65F8DE6, $92AEAF64, $3AC7D5E6, $9EA80509, + $F22B017D, $A4173F70, $DD1E16C3, $15E0D7F9, + $50B1B887, $2B9F4FD5, $625ABA82, $6A017962, + $2EC01B9C, $15488AA9, $D716E740, $40055A2C, + $93D29A22, $E32DBF9A, $058745B9, $3453DC1E, + $D699296E, $496CFF6F, $1C9F4986, $DFE2ED07, + $B87242D1, $19DE7EAE, $053E561A, $15AD6F8C, + $66626C1C, $7154C24C, $EA082B2A, $93EB2939, + $17DCB0F0, $58D4F2AE, $9EA294FB, $52CF564C, + $9883FE66, $2EC40581, $763953C3, $01D6692E, + $D3A0C108, $A1E7160E, $E4F2DFA6, $693ED285, + $74904698, $4C2B0EDD, $4F757656, $5D393378, + $A132234F, $3D321C5D, $C3F5E194, $4B269301, + $C79F022F, $3C997E7E, $5E4F9504, $3FFAFBBD, + $76F7AD0E, $296693F4, $3D1FCE6F, $C61E45BE, + $D3B5AB34, $F72BF9B7, $1B0434C0, $4E72B567, + $5592A33D, $B5229301, $CFD2A87F, $60AEB767, + $1814386B, $30BCC33D, $38A0C07D, $FD1606F2, + $C363519B, $589DD390, $5479F8E6, $1CB8D647, + $97FD61A9, $EA7759F4, $2D57539D, $569A58CF, + $E84E63AD, $462E1B78, $6580F87E, $F3817914, + $91DA55F4, $40A230F3, $D1988F35, $B6E318D2, + $3FFA50BC, $3D40F021, $C3C0BDAE, $4958C24C, + $518F36B2, $84B1D370, $0FEDCE83, $878DDADA, + $F2A279C7, $94E01BE8, $90716F4B, $954B8AA3 + ); + + cast_sbox8: array[0..255] of DWord = ( + $E216300D, $BBDDFFFC, $A7EBDABD, $35648095, + $7789F8B7, $E6C1121B, $0E241600, $052CE8B5, + $11A9CFB0, $E5952F11, $ECE7990A, $9386D174, + $2A42931C, $76E38111, $B12DEF3A, $37DDDDFC, + $DE9ADEB1, $0A0CC32C, $BE197029, $84A00940, + $BB243A0F, $B4D137CF, $B44E79F0, $049EEDFD, + $0B15A15D, $480D3168, $8BBBDE5A, $669DED42, + $C7ECE831, $3F8F95E7, $72DF191B, $7580330D, + $94074251, $5C7DCDFA, $ABBE6D63, $AA402164, + $B301D40A, $02E7D1CA, $53571DAE, $7A3182A2, + $12A8DDEC, $FDAA335D, $176F43E8, $71FB46D4, + $38129022, $CE949AD4, $B84769AD, $965BD862, + $82F3D055, $66FB9767, $15B80B4E, $1D5B47A0, + $4CFDE06F, $C28EC4B8, $57E8726E, $647A78FC, + $99865D44, $608BD593, $6C200E03, $39DC5FF6, + $5D0B00A3, $AE63AFF2, $7E8BD632, $70108C0C, + $BBD35049, $2998DF04, $980CF42A, $9B6DF491, + $9E7EDD53, $06918548, $58CB7E07, $3B74EF2E, + $522FFFB1, $D24708CC, $1C7E27CD, $A4EB215B, + $3CF1D2E2, $19B47A38, $424F7618, $35856039, + $9D17DEE7, $27EB35E6, $C9AFF67B, $36BAF5B8, + $09C467CD, $C18910B1, $E11DBF7B, $06CD1AF8, + $7170C608, $2D5E3354, $D4DE495A, $64C6D006, + $BCC0C62C, $3DD00DB3, $708F8F34, $77D51B42, + $264F620F, $24B8D2BF, $15C1B79E, $46A52564, + $F8D7E54E, $3E378160, $7895CDA5, $859C15A5, + $E6459788, $C37BC75F, $DB07BA0C, $0676A3AB, + $7F229B1E, $31842E7B, $24259FD7, $F8BEF472, + $835FFCB8, $6DF4C1F2, $96F5B195, $FD0AF0FC, + $B0FE134C, $E2506D3D, $4F9B12EA, $F215F225, + $A223736F, $9FB4C428, $25D04979, $34C713F8, + $C4618187, $EA7A6E98, $7CD16EFC, $1436876C, + $F1544107, $BEDEEE14, $56E9AF27, $A04AA441, + $3CF7C899, $92ECBAE6, $DD67016D, $151682EB, + $A842EEDF, $FDBA60B4, $F1907B75, $20E3030F, + $24D8C29E, $E139673B, $EFA63FB8, $71873054, + $B6F2CF3B, $9F326442, $CB15A4CC, $B01A4504, + $F1E47D8D, $844A1BE5, $BAE7DFDC, $42CBDA70, + $CD7DAE0A, $57E85B7A, $D53F5AF6, $20CF4D8C, + $CEA4D428, $79D130A4, $3486EBFB, $33D3CDDC, + $77853B53, $37EFFCB5, $C5068778, $E580B3E6, + $4E68B8F4, $C5C8B37E, $0D809EA2, $398FEB7C, + $132A4F94, $43B7950E, $2FEE7D1C, $223613BD, + $DD06CAA2, $37DF932B, $C4248289, $ACF3EBC3, + $5715F6B7, $EF3478DD, $F267616F, $C148CBE4, + $9052815E, $5E410FAB, $B48A2465, $2EDA7FA4, + $E87B40E4, $E98EA084, $5889E9E1, $EFD390FC, + $DD07D35B, $DB485694, $38D7E5B2, $57720101, + $730EDEBC, $5B643113, $94917E4F, $503C2FBA, + $646F1282, $7523D24A, $E0779695, $F9C17A8F, + $7A5B2121, $D187B896, $29263A4D, $BA510CDF, + $81F47C9F, $AD1163ED, $EA7B5965, $1A00726E, + $11403092, $00DA6D77, $4A0CDD61, $AD1F4603, + $605BDFB0, $9EEDC364, $22EBE6A8, $CEE7D28A, + $A0E736A0, $5564A6B9, $10853209, $C7EB8F37, + $2DE705CA, $8951570F, $DF09822B, $BD691A6C, + $AA12E4F2, $87451C0F, $E0F6A27A, $3ADA4819, + $4CF1764F, $0D771C2B, $67CDB156, $350D8384, + $5938FA0F, $42399EF3, $36997B07, $0E84093D, + $4AA93E61, $8360D87B, $1FA98B0C, $1149382C, + $E97625A5, $0614D1B7, $0E25244B, $0C768347, + $589E8D82, $0D2059D1, $A466BB1E, $F8DA0A82, + $04F19130, $BA6E4EC0, $99265164, $1EE7230D, + $50B2AD80, $EAEE6801, $8DB2A283, $EA8BF59E + ); + + +type + PCast128 = ^TCast128; + TCast128 = object(TBlockCipher64) + protected + KeyData: array[0..31] of DWord; + Rounds: longword; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//Cast256 cipher implementation +const + S1: array[0..255] of DWord= ( + $30fb40d4, $9fa0ff0b, $6beccd2f, $3f258c7a, $1e213f2f, $9C004dd3, + $6003e540, $cf9fc949, $bfd4af27, $88bbbdb5, $e2034090, $98d09675, + $6e63a0e0, $15c361d2, $c2e7661d, $22d4ff8e, $28683b6f, $c07fd059, + $ff2379c8, $775f50e2, $43c340d3, $df2f8656, $887ca41a, $a2d2bd2d, + $a1c9e0d6, $346c4819, $61b76d87, $22540f2f, $2abe32e1, $aa54166b, + $22568e3a, $a2d341d0, $66db40c8, $a784392f, $004dff2f, $2db9d2de, + $97943fac, $4a97c1d8, $527644b7, $b5f437a7, $b82cbaef, $d751d159, + $6ff7f0ed, $5a097a1f, $827b68d0, $90ecf52e, $22b0c054, $bc8e5935, + $4b6d2f7f, $50bb64a2, $d2664910, $bee5812d, $b7332290, $e93b159f, + $b48ee411, $4bff345d, $fd45c240, $ad31973f, $c4f6d02e, $55fc8165, + $d5b1caad, $a1ac2dae, $a2d4b76d, $c19b0C50, $882240f2, $0c6e4f38, + $a4e4bfd7, $4f5ba272, $564c1d2f, $c59c5319, $b949e354, $b04669fe, + $b1b6ab8a, $c71358dd, $6385c545, $110f935d, $57538ad5, $6a390493, + $e63d37e0, $2a54f6b3, $3a787d5f, $6276a0b5, $19a6fcdf, $7a42206a, + $29f9d4d5, $f61b1891, $bb72275e, $aa508167, $38901091, $c6b505eb, + $84c7cb8c, $2ad75a0f, $874a1427, $a2d1936b, $2ad286af, $aa56d291, + $d7894360, $425c750d, $93b39e26, $187184c9, $6c00b32d, $73e2bb14, + $a0bebc3c, $54623779, $64459eab, $3f328b82, $7718cf82, $59a2cea6, + $04ee002e, $89fe78e6, $3fab0950, $325ff6C2, $81383f05, $6963c5c8, + $76cb5ad6, $d49974c9, $ca180dcf, $380782d5, $c7fa5cf6, $8ac31511, + $35e79e13, $47da91d0, $f40f9086, $a7e2419e, $31366241, $051ef495, + $aa573b04, $4a805d8d, $548300d0, $00322a3c, $bf64cddf, $ba57a68e, + $75c6372b, $50afd341, $a7c13275, $915a0bf5, $6b54bfab, $2b0b1426, + $ab4cc9d7, $449ccd82, $f7fbf265, $ab85c5f3, $1b55db94, $aad4e324, + $cfa4bd3f, $2deaa3e2, $9e204d02, $c8bd25ac, $eadf55b3, $d5bd9e98, + $e31231b2, $2ad5ad6c, $954329de, $adbe4528, $d8710f69, $aa51c90f, + $aa786bf6, $22513f1e, $aa51a79b, $2ad344cc, $7b5a41f0, $d37cfbad, + $1b069505, $41ece491, $b4c332e6, $032268d4, $c9600acc, $ce387e6d, + $bf6bb16c, $6a70fb78, $0d03d9c9, $d4df39de, $e01063da, $4736f464, + $5ad328d8, $b347cc96, $75bb0fc3, $98511bfb, $4ffbcc35, $b58bcf6a, + $e11f0abc, $bfc5fe4a, $a70aec10, $ac39570a, $3f04442f, $6188b153, + $e0397a2e, $5727cb79, $9ceb418f, $1cacd68d, $2ad37c96, $0175cb9d, + $c69dff09, $c75b65f0, $d9db40d8, $ec0e7779, $4744ead4, $b11c3274, + $dd24cb9e, $7e1c54bd, $f01144f9, $d2240eb1, $9675b3fd, $a3ac3755, + $d47c27af, $51c85f4d, $56907596, $a5bb15e6, $580304f0, $ca042cf1, + $011a37ea, $8dbfaadb, $35ba3e4a, $3526ffa0, $c37b4d09, $bc306ed9, + $98a52666, $5648f725, $ff5e569d, $0ced63d0, $7c63b2cf, $700b45e1, + $d5ea50f1, $85a92872, $af1fbda7, $d4234870, $a7870bf3, $2d3b4d79, + $42e04198, $0cd0ede7, $26470db8, $f881814C, $474d6ad7, $7c0c5e5c, + $d1231959, $381b7298, $f5d2f4db, $ab838653, $6e2f1e23, $83719c9e, + $bd91e046, $9a56456e, $dc39200c, $20c8c571, $962bda1c, $e1e696ff, + $b141ab08, $7cca89b9, $1a69e783, $02cc4843, $a2f7c579, $429ef47d, + $427b169c, $5ac9f049, $dd8f0f00, $5c8165bf); + S2: array[0..255] of DWord= ( + $1f201094, $ef0ba75b, $69e3cf7e, $393f4380, $fe61cf7a, $eec5207a, + $55889c94, $72fc0651, $ada7ef79, $4e1d7235, $d55a63ce, $de0436ba, + $99c430ef, $5f0c0794, $18dcdb7d, $a1d6eff3, $a0b52f7b, $59e83605, + $ee15b094, $e9ffd909, $dc440086, $ef944459, $ba83ccb3, $e0c3cdfb, + $d1da4181, $3b092ab1, $f997f1c1, $a5e6cf7b, $01420ddb, $e4e7ef5b, + $25a1ff41, $e180f806, $1fc41080, $179bee7a, $d37ac6a9, $fe5830a4, + $98de8b7f, $77e83f4e, $79929269, $24fa9f7b, $e113c85b, $acc40083, + $d7503525, $f7ea615f, $62143154, $0d554b63, $5d681121, $c866c359, + $3d63cf73, $cee234c0, $d4d87e87, $5c672b21, $071f6181, $39f7627f, + $361e3084, $e4eb573b, $602f64a4, $d63acd9c, $1bbc4635, $9e81032d, + $2701f50c, $99847ab4, $a0e3df79, $ba6cf38c, $10843094, $2537a95e, + $f46f6ffe, $a1ff3b1f, $208cfb6a, $8f458c74, $d9e0a227, $4ec73a34, + $fc884f69, $3e4de8df, $ef0e0088, $3559648d, $8a45388c, $1d804366, + $721d9bfd, $a58684bb, $e8256333, $844e8212, $128d8098, $fed33fb4, + $ce280ae1, $27e19ba5, $d5a6c252, $e49754bd, $c5d655dd, $eb667064, + $77840b4d, $a1b6a801, $84db26a9, $e0b56714, $21f043b7, $e5d05860, + $54f03084, $066ff472, $a31aa153, $dadc4755, $b5625dbf, $68561be6, + $83ca6b94, $2d6ed23b, $eccf01db, $a6d3d0ba, $b6803d5c, $af77a709, + $33b4a34c, $397bc8d6, $5ee22b95, $5f0e5304, $81ed6f61, $20e74364, + $b45e1378, $de18639b, $881ca122, $b96726d1, $8049a7e8, $22b7da7b, + $5e552d25, $5272d237, $79d2951c, $c60d894c, $488cb402, $1ba4fe5b, + $a4b09f6b, $1ca815cf, $a20c3005, $8871df63, $b9de2fcb, $0cc6c9e9, + $0beeff53, $e3214517, $b4542835, $9f63293c, $ee41e729, $6e1d2d7c, + $50045286, $1e6685f3, $f33401c6, $30a22c95, $31a70850, $60930f13, + $73f98417, $a1269859, $ec645c44, $52c877a9, $cdff33a6, $a02b1741, + $7cbad9a2, $2180036f, $50d99c08, $cb3f4861, $c26bd765, $64a3f6ab, + $80342676, $25a75e7b, $e4e6d1fc, $20c710e6, $cdf0b680, $17844d3b, + $31eef84d, $7e0824e4, $2ccb49eb, $846a3bae, $8ff77888, $ee5d60f6, + $7af75673, $2fdd5cdb, $a11631c1, $30f66f43, $b3faec54, $157fd7fa, + $ef8579cc, $d152de58, $db2ffd5e, $8f32ce19, $306af97a, $02f03ef8, + $99319ad5, $c242fa0f, $a7e3ebb0, $c68e4906, $b8da230c, $80823028, + $dcdef3c8, $d35fb171, $088a1bc8, $bec0c560, $61a3c9e8, $bca8f54d, + $c72feffa, $22822e99, $82c570b4, $d8d94e89, $8b1c34bc, $301e16e6, + $273be979, $b0ffeaa6, $61d9b8c6, $00b24869, $b7ffce3f, $08dc283b, + $43daf65a, $f7e19798, $7619b72f, $8f1c9ba4, $dc8637a0, $16a7d3b1, + $9fc393b7, $a7136eeb, $c6bcc63e, $1a513742, $ef6828bc, $520365d6, + $2d6a77ab, $3527ed4b, $821fd216, $095c6e2e, $db92f2fb, $5eea29cb, + $145892f5, $91584f7f, $5483697b, $2667a8cc, $85196048, $8c4bacea, + $833860d4, $0d23e0f9, $6c387e8a, $0ae6d249, $b284600c, $d835731d, + $dcb1c647, $ac4c56ea, $3ebd81b3, $230eabb0, $6438bc87, $f0b5b1fa, + $8f5ea2b3, $fc184642, $0a036b7a, $4fb089bd, $649da589, $a345415e, + $5c038323, $3e5d3bb9, $43d79572, $7e6dd07c, $06dfdf1e, $6c6cc4ef, + $7160a539, $73bfbe70, $83877605, $4523ecf1); + S3: array[0..255] of DWord= ( + $8defc240, $25fa5d9f, $eb903dbf, $e810c907, $47607fff, $369fe44b, + $8c1fc644, $aececa90, $beb1f9bf, $eefbcaea, $e8cf1950, $51df07ae, + $920e8806, $f0ad0548, $e13c8d83, $927010d5, $11107d9f, $07647db9, + $b2e3e4d4, $3d4f285e, $b9afa820, $fade82e0, $a067268b, $8272792e, + $553fb2c0, $489ae22b, $d4ef9794, $125e3fbc, $21fffcee, $825b1bfd, + $9255c5ed, $1257a240, $4e1a8302, $bae07fff, $528246e7, $8e57140e, + $3373f7bf, $8c9f8188, $a6fc4ee8, $c982b5a5, $a8c01db7, $579fc264, + $67094f31, $f2bd3f5f, $40fff7c1, $1fb78dfc, $8e6bd2c1, $437be59b, + $99b03dbf, $b5dbc64b, $638dc0e6, $55819d99, $a197c81c, $4a012d6e, + $c5884a28, $ccc36f71, $b843c213, $6c0743f1, $8309893c, $0feddd5f, + $2f7fe850, $d7c07f7e, $02507fbf, $5afb9a04, $a747d2d0, $1651192e, + $af70bf3e, $58c31380, $5f98302e, $727cc3c4, $0a0fb402, $0f7fef82, + $8c96fdad, $5d2c2aae, $8ee99a49, $50da88b8, $8427f4a0, $1eac5790, + $796fb449, $8252dc15, $efbd7d9b, $a672597d, $ada840d8, $45f54504, + $fa5d7403, $e83ec305, $4f91751a, $925669c2, $23efe941, $a903f12e, + $60270df2, $0276e4b6, $94fd6574, $927985b2, $8276dbcb, $02778176, + $f8af918d, $4e48f79e, $8f616ddf, $e29d840e, $842f7d83, $340ce5c8, + $96bbb682, $93b4b148, $ef303cab, $984faf28, $779faf9b, $92dc560d, + $224d1e20, $8437aa88, $7d29dc96, $2756d3dc, $8b907cee, $b51fd240, + $e7c07ce3, $e566b4a1, $c3e9615e, $3cf8209d, $6094d1e3, $cd9ca341, + $5c76460e, $00ea983b, $d4d67881, $fd47572c, $f76cedd9, $bda8229c, + $127dadaa, $438a074e, $1f97c090, $081bdb8a, $93a07ebe, $b938ca15, + $97b03cff, $3dc2c0f8, $8d1ab2ec, $64380e51, $68cc7bfb, $d90f2788, + $12490181, $5de5ffd4, $dd7ef86a, $76a2e214, $b9a40368, $925d958f, + $4b39fffa, $ba39aee9, $a4ffd30b, $faf7933b, $6d498623, $193cbcfa, + $27627545, $825cf47a, $61bd8ba0, $d11e42d1, $cead04f4, $127ea392, + $10428db7, $8272a972, $9270c4a8, $127de50b, $285ba1c8, $3c62f44f, + $35c0eaa5, $e805d231, $428929fb, $b4fcdf82, $4fb66a53, $0e7dc15b, + $1f081fab, $108618ae, $fcfd086d, $f9ff2889, $694bcc11, $236a5cae, + $12deca4d, $2c3f8cc5, $d2d02dfe, $f8ef5896, $e4cf52da, $95155b67, + $494a488c, $b9b6a80c, $5c8f82bc, $89d36b45, $3a609437, $ec00c9a9, + $44715253, $0a874b49, $d773bc40, $7c34671c, $02717ef6, $4feb5536, + $a2d02fff, $d2bf60c4, $d43f03c0, $50b4ef6d, $07478cd1, $006e1888, + $a2e53f55, $b9e6d4bc, $a2048016, $97573833, $d7207d67, $de0f8f3d, + $72f87b33, $abcc4f33, $7688c55d, $7b00a6b0, $947b0001, $570075d2, + $f9bb88f8, $8942019e, $4264a5ff, $856302e0, $72dbd92b, $ee971b69, + $6ea22fde, $5f08ae2b, $af7a616d, $e5c98767, $cf1febd2, $61efc8c2, + $f1ac2571, $cc8239c2, $67214cb8, $b1e583d1, $b7dc3e62, $7f10bdce, + $f90a5c38, $0ff0443d, $606e6dc6, $60543a49, $5727c148, $2be98a1d, + $8ab41738, $20e1be24, $af96da0f, $68458425, $99833be5, $600d457d, + $282f9350, $8334b362, $d91d1120, $2b6d8da0, $642b1e31, $9c305a00, + $52bce688, $1b03588a, $f7baefd5, $4142ed9c, $a4315c11, $83323ec5, + $dfef4636, $a133c501, $e9d3531c, $ee353783); + S4: array[0..255] of DWord= ( + $9db30420, $1fb6e9de, $a7be7bef, $d273a298, $4a4f7bdb, $64ad8c57, + $85510443, $fa020ed1, $7e287aff, $e60fb663, $095f35a1, $79ebf120, + $fd059d43, $6497b7b1, $f3641f63, $241e4adf, $28147f5f, $4fa2b8cd, + $c9430040, $0cc32220, $fdd30b30, $c0a5374f, $1d2d00d9, $24147b15, + $ee4d111a, $0fca5167, $71ff904c, $2d195ffe, $1a05645f, $0c13fefe, + $081b08ca, $05170121, $80530100, $e83e5efe, $ac9af4f8, $7fe72701, + $d2b8ee5f, $06df4261, $bb9e9b8a, $7293ea25, $ce84ffdf, $f5718801, + $3dd64b04, $a26f263b, $7ed48400, $547eebe6, $446d4ca0, $6cf3d6f5, + $2649abdf, $aea0c7f5, $36338cc1, $503f7e93, $d3772061, $11b638e1, + $72500e03, $f80eb2bb, $abe0502e, $ec8d77de, $57971e81, $e14f6746, + $c9335400, $6920318f, $081dbb99, $ffc304a5, $4d351805, $7f3d5ce3, + $a6c866c6, $5d5bcca9, $daec6fea, $9f926f91, $9f46222f, $3991467d, + $a5bf6d8e, $1143c44f, $43958302, $d0214eeb, $022083b8, $3fb6180c, + $18f8931e, $281658e6, $26486e3e, $8bd78a70, $7477e4c1, $b506e07c, + $f32d0a25, $79098b02, $e4eabb81, $28123b23, $69dead38, $1574ca16, + $df871b62, $211c40b7, $a51a9ef9, $0014377b, $041e8ac8, $09114003, + $bd59e4d2, $e3d156d5, $4fe876d5, $2f91a340, $557be8de, $00eae4a7, + $0ce5c2ec, $4db4bba6, $e756bdff, $dd3369ac, $ec17b035, $06572327, + $99afc8b0, $56c8c391, $6b65811c, $5e146119, $6e85cb75, $be07c002, + $c2325577, $893ff4ec, $5bbfc92d, $d0ec3b25, $b7801ab7, $8d6d3b24, + $20c763ef, $c366a5fc, $9c382880, $0ace3205, $aac9548a, $eca1d7c7, + $041afa32, $1d16625a, $6701902c, $9b757a54, $31d477f7, $9126b031, + $36cc6fdb, $c70b8b46, $d9e66a48, $56e55a79, $026a4ceb, $52437eff, + $2f8f76b4, $0df980a5, $8674cde3, $edda04eb, $17a9be04, $2c18f4df, + $b7747f9d, $ab2af7b4, $efc34d20, $2e096b7c, $1741a254, $e5b6a035, + $213d42f6, $2c1c7c26, $61c2f50f, $6552daf9, $d2c231f8, $25130f69, + $d8167fa2, $0418f2c8, $001a96a6, $0d1526ab, $63315c21, $5e0a72ec, + $49bafefd, $187908d9, $8d0dbd86, $311170a7, $3e9b640c, $cc3e10d7, + $d5cad3b6, $0caec388, $f73001e1, $6c728aff, $71eae2a1, $1f9af36e, + $cfcbd12f, $c1de8417, $ac07be6b, $cb44a1d8, $8b9b0f56, $013988c3, + $b1c52fca, $b4be31cd, $d8782806, $12a3a4e2, $6f7de532, $58fd7eb6, + $d01ee900, $24adffc2, $f4990fc5, $9711aac5, $001d7b95, $82e5e7d2, + $109873f6, $00613096, $c32d9521, $ada121ff, $29908415, $7fbb977f, + $af9eb3db, $29c9ed2a, $5ce2a465, $a730f32c, $d0aa3fe8, $8a5cc091, + $d49e2ce7, $0ce454a9, $d60acd86, $015f1919, $77079103, $dea03af6, + $78a8565e, $dee356df, $21f05cbe, $8b75e387, $b3c50651, $b8a5c3ef, + $d8eeb6d2, $e523be77, $c2154529, $2f69efdf, $afe67afb, $f470c4b2, + $f3e0eb5b, $d6cc9876, $39e4460c, $1fda8538, $1987832f, $ca007367, + $a99144f8, $296b299e, $492fc295, $9266beab, $b5676e69, $9bd3ddda, + $df7e052f, $db25701c, $1b5e51ee, $f65324e6, $6afce36c, $0316cc04, + $8644213e, $b7dc59d0, $7965291f, $ccd6fd43, $41823979, $932bcdf6, + $b657c34d, $4edfd282, $7ae5290c, $3cb9536b, $851e20fe, $9833557e, + $13ecf0b0, $d3ffb372, $3f85c5c1, $0aef7ed2); + + +type + PCast256 = ^TCast256; + TCast256= object(TBlockCipher128) + protected + Kr, Km: array[0..11,0..3] of DWord; + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + + +//GOST cipher implementation +const + sTable: array[0..3, 0..255] of DWord= ( + ($00072000,$00075000,$00074800,$00071000,$00076800,$00074000,$00070000,$00077000, + $00073000,$00075800,$00070800,$00076000,$00073800,$00077800,$00072800,$00071800, + $0005A000,$0005D000,$0005C800,$00059000,$0005E800,$0005C000,$00058000,$0005F000, + $0005B000,$0005D800,$00058800,$0005E000,$0005B800,$0005F800,$0005A800,$00059800, + $00022000,$00025000,$00024800,$00021000,$00026800,$00024000,$00020000,$00027000, + $00023000,$00025800,$00020800,$00026000,$00023800,$00027800,$00022800,$00021800, + $00062000,$00065000,$00064800,$00061000,$00066800,$00064000,$00060000,$00067000, + $00063000,$00065800,$00060800,$00066000,$00063800,$00067800,$00062800,$00061800, + $00032000,$00035000,$00034800,$00031000,$00036800,$00034000,$00030000,$00037000, + $00033000,$00035800,$00030800,$00036000,$00033800,$00037800,$00032800,$00031800, + $0006A000,$0006D000,$0006C800,$00069000,$0006E800,$0006C000,$00068000,$0006F000, + $0006B000,$0006D800,$00068800,$0006E000,$0006B800,$0006F800,$0006A800,$00069800, + $0007A000,$0007D000,$0007C800,$00079000,$0007E800,$0007C000,$00078000,$0007F000, + $0007B000,$0007D800,$00078800,$0007E000,$0007B800,$0007F800,$0007A800,$00079800, + $00052000,$00055000,$00054800,$00051000,$00056800,$00054000,$00050000,$00057000, + $00053000,$00055800,$00050800,$00056000,$00053800,$00057800,$00052800,$00051800, + $00012000,$00015000,$00014800,$00011000,$00016800,$00014000,$00010000,$00017000, + $00013000,$00015800,$00010800,$00016000,$00013800,$00017800,$00012800,$00011800, + $0001A000,$0001D000,$0001C800,$00019000,$0001E800,$0001C000,$00018000,$0001F000, + $0001B000,$0001D800,$00018800,$0001E000,$0001B800,$0001F800,$0001A800,$00019800, + $00042000,$00045000,$00044800,$00041000,$00046800,$00044000,$00040000,$00047000, + $00043000,$00045800,$00040800,$00046000,$00043800,$00047800,$00042800,$00041800, + $0000A000,$0000D000,$0000C800,$00009000,$0000E800,$0000C000,$00008000,$0000F000, + $0000B000,$0000D800,$00008800,$0000E000,$0000B800,$0000F800,$0000A800,$00009800, + $00002000,$00005000,$00004800,$00001000,$00006800,$00004000,$00000000,$00007000, + $00003000,$00005800,$00000800,$00006000,$00003800,$00007800,$00002800,$00001800, + $0003A000,$0003D000,$0003C800,$00039000,$0003E800,$0003C000,$00038000,$0003F000, + $0003B000,$0003D800,$00038800,$0003E000,$0003B800,$0003F800,$0003A800,$00039800, + $0002A000,$0002D000,$0002C800,$00029000,$0002E800,$0002C000,$00028000,$0002F000, + $0002B000,$0002D800,$00028800,$0002E000,$0002B800,$0002F800,$0002A800,$00029800, + $0004A000,$0004D000,$0004C800,$00049000,$0004E800,$0004C000,$00048000,$0004F000, + $0004B000,$0004D800,$00048800,$0004E000,$0004B800,$0004F800,$0004A800,$00049800), + ($03A80000,$03C00000,$03880000,$03E80000,$03D00000,$03980000,$03A00000,$03900000, + $03F00000,$03F80000,$03E00000,$03B80000,$03B00000,$03800000,$03C80000,$03D80000, + $06A80000,$06C00000,$06880000,$06E80000,$06D00000,$06980000,$06A00000,$06900000, + $06F00000,$06F80000,$06E00000,$06B80000,$06B00000,$06800000,$06C80000,$06D80000, + $05280000,$05400000,$05080000,$05680000,$05500000,$05180000,$05200000,$05100000, + $05700000,$05780000,$05600000,$05380000,$05300000,$05000000,$05480000,$05580000, + $00A80000,$00C00000,$00880000,$00E80000,$00D00000,$00980000,$00A00000,$00900000, + $00F00000,$00F80000,$00E00000,$00B80000,$00B00000,$00800000,$00C80000,$00D80000, + $00280000,$00400000,$00080000,$00680000,$00500000,$00180000,$00200000,$00100000, + $00700000,$00780000,$00600000,$00380000,$00300000,$00000000,$00480000,$00580000, + $04280000,$04400000,$04080000,$04680000,$04500000,$04180000,$04200000,$04100000, + $04700000,$04780000,$04600000,$04380000,$04300000,$04000000,$04480000,$04580000, + $04A80000,$04C00000,$04880000,$04E80000,$04D00000,$04980000,$04A00000,$04900000, + $04F00000,$04F80000,$04E00000,$04B80000,$04B00000,$04800000,$04C80000,$04D80000, + $07A80000,$07C00000,$07880000,$07E80000,$07D00000,$07980000,$07A00000,$07900000, + $07F00000,$07F80000,$07E00000,$07B80000,$07B00000,$07800000,$07C80000,$07D80000, + $07280000,$07400000,$07080000,$07680000,$07500000,$07180000,$07200000,$07100000, + $07700000,$07780000,$07600000,$07380000,$07300000,$07000000,$07480000,$07580000, + $02280000,$02400000,$02080000,$02680000,$02500000,$02180000,$02200000,$02100000, + $02700000,$02780000,$02600000,$02380000,$02300000,$02000000,$02480000,$02580000, + $03280000,$03400000,$03080000,$03680000,$03500000,$03180000,$03200000,$03100000, + $03700000,$03780000,$03600000,$03380000,$03300000,$03000000,$03480000,$03580000, + $06280000,$06400000,$06080000,$06680000,$06500000,$06180000,$06200000,$06100000, + $06700000,$06780000,$06600000,$06380000,$06300000,$06000000,$06480000,$06580000, + $05A80000,$05C00000,$05880000,$05E80000,$05D00000,$05980000,$05A00000,$05900000, + $05F00000,$05F80000,$05E00000,$05B80000,$05B00000,$05800000,$05C80000,$05D80000, + $01280000,$01400000,$01080000,$01680000,$01500000,$01180000,$01200000,$01100000, + $01700000,$01780000,$01600000,$01380000,$01300000,$01000000,$01480000,$01580000, + $02A80000,$02C00000,$02880000,$02E80000,$02D00000,$02980000,$02A00000,$02900000, + $02F00000,$02F80000,$02E00000,$02B80000,$02B00000,$02800000,$02C80000,$02D80000, + $01A80000,$01C00000,$01880000,$01E80000,$01D00000,$01980000,$01A00000,$01900000, + $01F00000,$01F80000,$01E00000,$01B80000,$01B00000,$01800000,$01C80000,$01D80000), + ($30000002,$60000002,$38000002,$08000002,$28000002,$78000002,$68000002,$40000002, + $20000002,$50000002,$48000002,$70000002,$00000002,$18000002,$58000002,$10000002, + $B0000005,$E0000005,$B8000005,$88000005,$A8000005,$F8000005,$E8000005,$C0000005, + $A0000005,$D0000005,$C8000005,$F0000005,$80000005,$98000005,$D8000005,$90000005, + $30000005,$60000005,$38000005,$08000005,$28000005,$78000005,$68000005,$40000005, + $20000005,$50000005,$48000005,$70000005,$00000005,$18000005,$58000005,$10000005, + $30000000,$60000000,$38000000,$08000000,$28000000,$78000000,$68000000,$40000000, + $20000000,$50000000,$48000000,$70000000,$00000000,$18000000,$58000000,$10000000, + $B0000003,$E0000003,$B8000003,$88000003,$A8000003,$F8000003,$E8000003,$C0000003, + $A0000003,$D0000003,$C8000003,$F0000003,$80000003,$98000003,$D8000003,$90000003, + $30000001,$60000001,$38000001,$08000001,$28000001,$78000001,$68000001,$40000001, + $20000001,$50000001,$48000001,$70000001,$00000001,$18000001,$58000001,$10000001, + $B0000000,$E0000000,$B8000000,$88000000,$A8000000,$F8000000,$E8000000,$C0000000, + $A0000000,$D0000000,$C8000000,$F0000000,$80000000,$98000000,$D8000000,$90000000, + $B0000006,$E0000006,$B8000006,$88000006,$A8000006,$F8000006,$E8000006,$C0000006, + $A0000006,$D0000006,$C8000006,$F0000006,$80000006,$98000006,$D8000006,$90000006, + $B0000001,$E0000001,$B8000001,$88000001,$A8000001,$F8000001,$E8000001,$C0000001, + $A0000001,$D0000001,$C8000001,$F0000001,$80000001,$98000001,$D8000001,$90000001, + $30000003,$60000003,$38000003,$08000003,$28000003,$78000003,$68000003,$40000003, + $20000003,$50000003,$48000003,$70000003,$00000003,$18000003,$58000003,$10000003, + $30000004,$60000004,$38000004,$08000004,$28000004,$78000004,$68000004,$40000004, + $20000004,$50000004,$48000004,$70000004,$00000004,$18000004,$58000004,$10000004, + $B0000002,$E0000002,$B8000002,$88000002,$A8000002,$F8000002,$E8000002,$C0000002, + $A0000002,$D0000002,$C8000002,$F0000002,$80000002,$98000002,$D8000002,$90000002, + $B0000004,$E0000004,$B8000004,$88000004,$A8000004,$F8000004,$E8000004,$C0000004, + $A0000004,$D0000004,$C8000004,$F0000004,$80000004,$98000004,$D8000004,$90000004, + $30000006,$60000006,$38000006,$08000006,$28000006,$78000006,$68000006,$40000006, + $20000006,$50000006,$48000006,$70000006,$00000006,$18000006,$58000006,$10000006, + $B0000007,$E0000007,$B8000007,$88000007,$A8000007,$F8000007,$E8000007,$C0000007, + $A0000007,$D0000007,$C8000007,$F0000007,$80000007,$98000007,$D8000007,$90000007, + $30000007,$60000007,$38000007,$08000007,$28000007,$78000007,$68000007,$40000007, + $20000007,$50000007,$48000007,$70000007,$00000007,$18000007,$58000007,$10000007), + ($000000E8,$000000D8,$000000A0,$00000088,$00000098,$000000F8,$000000A8,$000000C8, + $00000080,$000000D0,$000000F0,$000000B8,$000000B0,$000000C0,$00000090,$000000E0, + $000007E8,$000007D8,$000007A0,$00000788,$00000798,$000007F8,$000007A8,$000007C8, + $00000780,$000007D0,$000007F0,$000007B8,$000007B0,$000007C0,$00000790,$000007E0, + $000006E8,$000006D8,$000006A0,$00000688,$00000698,$000006F8,$000006A8,$000006C8, + $00000680,$000006D0,$000006F0,$000006B8,$000006B0,$000006C0,$00000690,$000006E0, + $00000068,$00000058,$00000020,$00000008,$00000018,$00000078,$00000028,$00000048, + $00000000,$00000050,$00000070,$00000038,$00000030,$00000040,$00000010,$00000060, + $000002E8,$000002D8,$000002A0,$00000288,$00000298,$000002F8,$000002A8,$000002C8, + $00000280,$000002D0,$000002F0,$000002B8,$000002B0,$000002C0,$00000290,$000002E0, + $000003E8,$000003D8,$000003A0,$00000388,$00000398,$000003F8,$000003A8,$000003C8, + $00000380,$000003D0,$000003F0,$000003B8,$000003B0,$000003C0,$00000390,$000003E0, + $00000568,$00000558,$00000520,$00000508,$00000518,$00000578,$00000528,$00000548, + $00000500,$00000550,$00000570,$00000538,$00000530,$00000540,$00000510,$00000560, + $00000268,$00000258,$00000220,$00000208,$00000218,$00000278,$00000228,$00000248, + $00000200,$00000250,$00000270,$00000238,$00000230,$00000240,$00000210,$00000260, + $000004E8,$000004D8,$000004A0,$00000488,$00000498,$000004F8,$000004A8,$000004C8, + $00000480,$000004D0,$000004F0,$000004B8,$000004B0,$000004C0,$00000490,$000004E0, + $00000168,$00000158,$00000120,$00000108,$00000118,$00000178,$00000128,$00000148, + $00000100,$00000150,$00000170,$00000138,$00000130,$00000140,$00000110,$00000160, + $000001E8,$000001D8,$000001A0,$00000188,$00000198,$000001F8,$000001A8,$000001C8, + $00000180,$000001D0,$000001F0,$000001B8,$000001B0,$000001C0,$00000190,$000001E0, + $00000768,$00000758,$00000720,$00000708,$00000718,$00000778,$00000728,$00000748, + $00000700,$00000750,$00000770,$00000738,$00000730,$00000740,$00000710,$00000760, + $00000368,$00000358,$00000320,$00000308,$00000318,$00000378,$00000328,$00000348, + $00000300,$00000350,$00000370,$00000338,$00000330,$00000340,$00000310,$00000360, + $000005E8,$000005D8,$000005A0,$00000588,$00000598,$000005F8,$000005A8,$000005C8, + $00000580,$000005D0,$000005F0,$000005B8,$000005B0,$000005C0,$00000590,$000005E0, + $00000468,$00000458,$00000420,$00000408,$00000418,$00000478,$00000428,$00000448, + $00000400,$00000450,$00000470,$00000438,$00000430,$00000440,$00000410,$00000460, + $00000668,$00000658,$00000620,$00000608,$00000618,$00000678,$00000628,$00000648, + $00000600,$00000650,$00000670,$00000638,$00000630,$00000640,$00000610,$00000660)); + +type + PGOST = ^TGOST; + TGOST = object(TBlockCipher64) + protected + KeyData: array[0..7] of DWord; + // code + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//IDEA cipher implementation +type + PIDEA = ^TIDEA; + TIDEA = object(TBlockCipher64) + protected + EK, DK: array[0..51] of word; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//Misty1 cipher implementation +const + NUMROUNDSMY1 = 8; + +const + S7TABLE: array[0..$7F] of byte= ( + $1b, $32, $33, $5a, $3b, $10, $17, $54, $5b, $1a, $72, $73, $6b, $2c, $66, $49, + $1f, $24, $13, $6c, $37, $2e, $3f, $4a, $5d, $0f, $40, $56, $25, $51, $1c, $04, + $0b, $46, $20, $0d, $7b, $35, $44, $42, $2b, $1e, $41, $14, $4b, $79, $15, $6f, + $0e, $55, $09, $36, $74, $0c, $67, $53, $28, $0a, $7e, $38, $02, $07, $60, $29, + $19, $12, $65, $2f, $30, $39, $08, $68, $5f, $78, $2a, $4c, $64, $45, $75, $3d, + $59, $48, $03, $57, $7c, $4f, $62, $3c, $1d, $21, $5e, $27, $6a, $70, $4d, $3a, + $01, $6d, $6e, $63, $18, $77, $23, $05, $26, $76, $00, $31, $2d, $7a, $7f, $61, + $50, $22, $11, $06, $47, $16, $52, $4e, $71, $3e, $69, $43, $34, $5c, $58, $7d); + S9TABLE: array[0..$1FF] of Dword= ( + $1c3, $0cb, $153, $19f, $1e3, $0e9, $0fb, $035, $181, $0b9, $117, $1eb, $133, $009, $02d, $0d3, + $0c7, $14a, $037, $07e, $0eb, $164, $193, $1d8, $0a3, $11e, $055, $02c, $01d, $1a2, $163, $118, + $14b, $152, $1d2, $00f, $02b, $030, $13a, $0e5, $111, $138, $18e, $063, $0e3, $0c8, $1f4, $01b, + $001, $09d, $0f8, $1a0, $16d, $1f3, $01c, $146, $07d, $0d1, $082, $1ea, $183, $12d, $0f4, $19e, + $1d3, $0dd, $1e2, $128, $1e0, $0ec, $059, $091, $011, $12f, $026, $0dc, $0b0, $18c, $10f, $1f7, + $0e7, $16c, $0b6, $0f9, $0d8, $151, $101, $14c, $103, $0b8, $154, $12b, $1ae, $017, $071, $00c, + $047, $058, $07f, $1a4, $134, $129, $084, $15d, $19d, $1b2, $1a3, $048, $07c, $051, $1ca, $023, + $13d, $1a7, $165, $03b, $042, $0da, $192, $0ce, $0c1, $06b, $09f, $1f1, $12c, $184, $0fa, $196, + $1e1, $169, $17d, $031, $180, $10a, $094, $1da, $186, $13e, $11c, $060, $175, $1cf, $067, $119, + $065, $068, $099, $150, $008, $007, $17c, $0b7, $024, $019, $0de, $127, $0db, $0e4, $1a9, $052, + $109, $090, $19c, $1c1, $028, $1b3, $135, $16a, $176, $0df, $1e5, $188, $0c5, $16e, $1de, $1b1, + $0c3, $1df, $036, $0ee, $1ee, $0f0, $093, $049, $09a, $1b6, $069, $081, $125, $00b, $05e, $0b4, + $149, $1c7, $174, $03e, $13b, $1b7, $08e, $1c6, $0ae, $010, $095, $1ef, $04e, $0f2, $1fd, $085, + $0fd, $0f6, $0a0, $16f, $083, $08a, $156, $09b, $13c, $107, $167, $098, $1d0, $1e9, $003, $1fe, + $0bd, $122, $089, $0d2, $18f, $012, $033, $06a, $142, $0ed, $170, $11b, $0e2, $14f, $158, $131, + $147, $05d, $113, $1cd, $079, $161, $1a5, $179, $09e, $1b4, $0cc, $022, $132, $01a, $0e8, $004, + $187, $1ed, $197, $039, $1bf, $1d7, $027, $18b, $0c6, $09c, $0d0, $14e, $06c, $034, $1f2, $06e, + $0ca, $025, $0ba, $191, $0fe, $013, $106, $02f, $1ad, $172, $1db, $0c0, $10b, $1d6, $0f5, $1ec, + $10d, $076, $114, $1ab, $075, $10c, $1e4, $159, $054, $11f, $04b, $0c4, $1be, $0f7, $029, $0a4, + $00e, $1f0, $077, $04d, $17a, $086, $08b, $0b3, $171, $0bf, $10e, $104, $097, $15b, $160, $168, + $0d7, $0bb, $066, $1ce, $0fc, $092, $1c5, $06f, $016, $04a, $0a1, $139, $0af, $0f1, $190, $00a, + $1aa, $143, $17b, $056, $18d, $166, $0d4, $1fb, $14d, $194, $19a, $087, $1f8, $123, $0a7, $1b8, + $141, $03c, $1f9, $140, $02a, $155, $11a, $1a1, $198, $0d5, $126, $1af, $061, $12e, $157, $1dc, + $072, $18a, $0aa, $096, $115, $0ef, $045, $07b, $08d, $145, $053, $05f, $178, $0b2, $02e, $020, + $1d5, $03f, $1c9, $1e7, $1ac, $044, $038, $014, $0b1, $16b, $0ab, $0b5, $05a, $182, $1c8, $1d4, + $018, $177, $064, $0cf, $06d, $100, $199, $130, $15a, $005, $120, $1bb, $1bd, $0e0, $04f, $0d6, + $13f, $1c4, $12a, $015, $006, $0ff, $19b, $0a6, $043, $088, $050, $15f, $1e8, $121, $073, $17e, + $0bc, $0c2, $0c9, $173, $189, $1f5, $074, $1cc, $1e6, $1a8, $195, $01f, $041, $00d, $1ba, $032, + $03d, $1d1, $080, $0a8, $057, $1b9, $162, $148, $0d9, $105, $062, $07a, $021, $1ff, $112, $108, + $1c0, $0a9, $11d, $1b0, $1a6, $0cd, $0f3, $05c, $102, $05b, $1d9, $144, $1f6, $0ad, $0a5, $03a, + $1cb, $136, $17f, $046, $0e1, $01e, $1dd, $0e6, $137, $1fa, $185, $08c, $08f, $040, $1b5, $0be, + $078, $000, $0ac, $110, $15e, $124, $002, $1bc, $0a2, $0ea, $070, $1fc, $116, $15c, $04c, $1c2); + +type + PMisty1 = ^TMisty1; + TMisty1 = object(TBlockCipher64) + protected + + KeyData: array[0..31] of DWord; + function FI(const FI_IN, FI_KEY: DWord): DWord; + function FO(const FO_IN: DWord; const k: longword): DWord; + function FL(const FL_IN: DWord; const k: longword): DWord; + function FLINV(const FL_IN: DWord; const k: longword): DWord; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//RC2 cipher implementation +const + sBoxRC2: array[0..255] of byte= ( + $D9,$78,$F9,$C4,$19,$DD,$B5,$ED,$28,$E9,$FD,$79,$4A,$A0,$D8,$9D, + $C6,$7E,$37,$83,$2B,$76,$53,$8E,$62,$4C,$64,$88,$44,$8B,$FB,$A2, + $17,$9A,$59,$F5,$87,$B3,$4F,$13,$61,$45,$6D,$8D,$09,$81,$7D,$32, + $BD,$8F,$40,$EB,$86,$B7,$7B,$0B,$F0,$95,$21,$22,$5C,$6B,$4E,$82, + $54,$D6,$65,$93,$CE,$60,$B2,$1C,$73,$56,$C0,$14,$A7,$8C,$F1,$DC, + $12,$75,$CA,$1F,$3B,$BE,$E4,$D1,$42,$3D,$D4,$30,$A3,$3C,$B6,$26, + $6F,$BF,$0E,$DA,$46,$69,$07,$57,$27,$F2,$1D,$9B,$BC,$94,$43,$03, + $F8,$11,$C7,$F6,$90,$EF,$3E,$E7,$06,$C3,$D5,$2F,$C8,$66,$1E,$D7, + $08,$E8,$EA,$DE,$80,$52,$EE,$F7,$84,$AA,$72,$AC,$35,$4D,$6A,$2A, + $96,$1A,$D2,$71,$5A,$15,$49,$74,$4B,$9F,$D0,$5E,$04,$18,$A4,$EC, + $C2,$E0,$41,$6E,$0F,$51,$CB,$CC,$24,$91,$AF,$50,$A1,$F4,$70,$39, + $99,$7C,$3A,$85,$23,$B8,$B4,$7A,$FC,$02,$36,$5B,$25,$55,$97,$31, + $2D,$5D,$FA,$98,$E3,$8A,$92,$AE,$05,$DF,$29,$10,$67,$6C,$BA,$C9, + $D3,$00,$E6,$CF,$E1,$9E,$A8,$2C,$63,$16,$01,$3F,$58,$E2,$89,$A9, + $0D,$38,$34,$1B,$AB,$33,$FF,$B0,$BB,$48,$0C,$5F,$B9,$B1,$CD,$2E, + $C5,$F3,$DB,$47,$E5,$A5,$9C,$77,$0A,$A6,$20,$68,$FE,$7F,$C1,$AD); + +type + PRC2 = ^TRC2; + TRC2 = object(TBlockCipher64) + protected + KeyData: array[0..63] of word; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//RC5 cipher implementation +const + NUMROUNDSRC5= 12; { number of rounds must be between 12-16 } + +const + sBoxRC5: array[0..33] of dword= ( + $B7E15163,$5618CB1C,$F45044D5,$9287BE8E,$30BF3847,$CEF6B200, + $6D2E2BB9,$0B65A572,$A99D1F2B,$47D498E4,$E60C129D,$84438C56, + $227B060F,$C0B27FC8,$5EE9F981,$FD21733A,$9B58ECF3,$399066AC, + $D7C7E065,$75FF5A1E,$1436D3D7,$B26E4D90,$50A5C749,$EEDD4102, + $8D14BABB,$2B4C3474,$C983AE2D,$67BB27E6,$05F2A19F,$A42A1B58, + $42619511,$E0990ECA,$7ED08883,$1D08023C); + + +type + PRC5 = ^TRC5; + TRC5 = object(TBlockCipher64) + protected + KeyData: array[0..((NUMROUNDSRC5*2)+1)] of DWord; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +//RC6 cipher implementation +const + NUMROUNDSRC6= 20; { number of rounds must be between 16-24 } + +const + sBoxRC6: array[0..51] of DWord= ( + $B7E15163,$5618CB1C,$F45044D5,$9287BE8E,$30BF3847,$CEF6B200, + $6D2E2BB9,$0B65A572,$A99D1F2B,$47D498E4,$E60C129D,$84438C56, + $227B060F,$C0B27FC8,$5EE9F981,$FD21733A,$9B58ECF3,$399066AC, + $D7C7E065,$75FF5A1E,$1436D3D7,$B26E4D90,$50A5C749,$EEDD4102, + $8D14BABB,$2B4C3474,$C983AE2D,$67BB27E6,$05F2A19F,$A42A1B58, + $42619511,$E0990ECA,$7ED08883,$1D08023C,$BB3F7BF5,$5976F5AE, + $F7AE6F67,$95E5E920,$341D62D9,$D254DC92,$708C564B,$0EC3D004, + $ACFB49BD,$4B32C376,$E96A3D2F,$87A1B6E8,$25D930A1,$C410AA5A, + $62482413,$007F9DCC,$9EB71785,$3CEE913E); + + +type + PRC6 = ^TRC6; + TRC6 = object(TBlockCipher128) + protected + KeyData: array[0..((NUMROUNDSRC6*2)+3)] of DWord; + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + destructor Destroy; virtual; + end; + + +//TEA cipher implementation +const + Delta= $9e3779b9; + Rounds= 32; + +type + PTEA = ^TTEA; + TTEA = object(TBlockCipher64) + protected + KeyData: array[0..3] of dword; + + public + // code + procedure Burn;virtual; + procedure InitKey(const Key; Size: longword);virtual; + procedure EncryptECB(const InData; var OutData);virtual; + procedure DecryptECB(const InData; var OutData);virtual; + + destructor Destroy; virtual; + end; + +// DES and 3DES cipher implementation +const + shifts2: array[0..15]of byte= + (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); + + des_skb: array[0..7,0..63]of dword=( + ( + (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + $00000000,$00000010,$20000000,$20000010, + $00010000,$00010010,$20010000,$20010010, + $00000800,$00000810,$20000800,$20000810, + $00010800,$00010810,$20010800,$20010810, + $00000020,$00000030,$20000020,$20000030, + $00010020,$00010030,$20010020,$20010030, + $00000820,$00000830,$20000820,$20000830, + $00010820,$00010830,$20010820,$20010830, + $00080000,$00080010,$20080000,$20080010, + $00090000,$00090010,$20090000,$20090010, + $00080800,$00080810,$20080800,$20080810, + $00090800,$00090810,$20090800,$20090810, + $00080020,$00080030,$20080020,$20080030, + $00090020,$00090030,$20090020,$20090030, + $00080820,$00080830,$20080820,$20080830, + $00090820,$00090830,$20090820,$20090830 + ),( + (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) + $00000000,$02000000,$00002000,$02002000, + $00200000,$02200000,$00202000,$02202000, + $00000004,$02000004,$00002004,$02002004, + $00200004,$02200004,$00202004,$02202004, + $00000400,$02000400,$00002400,$02002400, + $00200400,$02200400,$00202400,$02202400, + $00000404,$02000404,$00002404,$02002404, + $00200404,$02200404,$00202404,$02202404, + $10000000,$12000000,$10002000,$12002000, + $10200000,$12200000,$10202000,$12202000, + $10000004,$12000004,$10002004,$12002004, + $10200004,$12200004,$10202004,$12202004, + $10000400,$12000400,$10002400,$12002400, + $10200400,$12200400,$10202400,$12202400, + $10000404,$12000404,$10002404,$12002404, + $10200404,$12200404,$10202404,$12202404 + ),( + (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) + $00000000,$00000001,$00040000,$00040001, + $01000000,$01000001,$01040000,$01040001, + $00000002,$00000003,$00040002,$00040003, + $01000002,$01000003,$01040002,$01040003, + $00000200,$00000201,$00040200,$00040201, + $01000200,$01000201,$01040200,$01040201, + $00000202,$00000203,$00040202,$00040203, + $01000202,$01000203,$01040202,$01040203, + $08000000,$08000001,$08040000,$08040001, + $09000000,$09000001,$09040000,$09040001, + $08000002,$08000003,$08040002,$08040003, + $09000002,$09000003,$09040002,$09040003, + $08000200,$08000201,$08040200,$08040201, + $09000200,$09000201,$09040200,$09040201, + $08000202,$08000203,$08040202,$08040203, + $09000202,$09000203,$09040202,$09040203 + ),( + (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) + $00000000,$00100000,$00000100,$00100100, + $00000008,$00100008,$00000108,$00100108, + $00001000,$00101000,$00001100,$00101100, + $00001008,$00101008,$00001108,$00101108, + $04000000,$04100000,$04000100,$04100100, + $04000008,$04100008,$04000108,$04100108, + $04001000,$04101000,$04001100,$04101100, + $04001008,$04101008,$04001108,$04101108, + $00020000,$00120000,$00020100,$00120100, + $00020008,$00120008,$00020108,$00120108, + $00021000,$00121000,$00021100,$00121100, + $00021008,$00121008,$00021108,$00121108, + $04020000,$04120000,$04020100,$04120100, + $04020008,$04120008,$04020108,$04120108, + $04021000,$04121000,$04021100,$04121100, + $04021008,$04121008,$04021108,$04121108 + ),( + (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + $00000000,$10000000,$00010000,$10010000, + $00000004,$10000004,$00010004,$10010004, + $20000000,$30000000,$20010000,$30010000, + $20000004,$30000004,$20010004,$30010004, + $00100000,$10100000,$00110000,$10110000, + $00100004,$10100004,$00110004,$10110004, + $20100000,$30100000,$20110000,$30110000, + $20100004,$30100004,$20110004,$30110004, + $00001000,$10001000,$00011000,$10011000, + $00001004,$10001004,$00011004,$10011004, + $20001000,$30001000,$20011000,$30011000, + $20001004,$30001004,$20011004,$30011004, + $00101000,$10101000,$00111000,$10111000, + $00101004,$10101004,$00111004,$10111004, + $20101000,$30101000,$20111000,$30111000, + $20101004,$30101004,$20111004,$30111004 + ),( + (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) + $00000000,$08000000,$00000008,$08000008, + $00000400,$08000400,$00000408,$08000408, + $00020000,$08020000,$00020008,$08020008, + $00020400,$08020400,$00020408,$08020408, + $00000001,$08000001,$00000009,$08000009, + $00000401,$08000401,$00000409,$08000409, + $00020001,$08020001,$00020009,$08020009, + $00020401,$08020401,$00020409,$08020409, + $02000000,$0A000000,$02000008,$0A000008, + $02000400,$0A000400,$02000408,$0A000408, + $02020000,$0A020000,$02020008,$0A020008, + $02020400,$0A020400,$02020408,$0A020408, + $02000001,$0A000001,$02000009,$0A000009, + $02000401,$0A000401,$02000409,$0A000409, + $02020001,$0A020001,$02020009,$0A020009, + $02020401,$0A020401,$02020409,$0A020409 + ),( + (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) + $00000000,$00000100,$00080000,$00080100, + $01000000,$01000100,$01080000,$01080100, + $00000010,$00000110,$00080010,$00080110, + $01000010,$01000110,$01080010,$01080110, + $00200000,$00200100,$00280000,$00280100, + $01200000,$01200100,$01280000,$01280100, + $00200010,$00200110,$00280010,$00280110, + $01200010,$01200110,$01280010,$01280110, + $00000200,$00000300,$00080200,$00080300, + $01000200,$01000300,$01080200,$01080300, + $00000210,$00000310,$00080210,$00080310, + $01000210,$01000310,$01080210,$01080310, + $00200200,$00200300,$00280200,$00280300, + $01200200,$01200300,$01280200,$01280300, + $00200210,$00200310,$00280210,$00280310, + $01200210,$01200310,$01280210,$01280310 + ),( + (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) + $00000000,$04000000,$00040000,$04040000, + $00000002,$04000002,$00040002,$04040002, + $00002000,$04002000,$00042000,$04042000, + $00002002,$04002002,$00042002,$04042002, + $00000020,$04000020,$00040020,$04040020, + $00000022,$04000022,$00040022,$04040022, + $00002020,$04002020,$00042020,$04042020, + $00002022,$04002022,$00042022,$04042022, + $00000800,$04000800,$00040800,$04040800, + $00000802,$04000802,$00040802,$04040802, + $00002800,$04002800,$00042800,$04042800, + $00002802,$04002802,$00042802,$04042802, + $00000820,$04000820,$00040820,$04040820, + $00000822,$04000822,$00040822,$04040822, + $00002820,$04002820,$00042820,$04042820, + $00002822,$04002822,$00042822,$04042822 + )); + + des_sptrans: array[0..7,0..63] of dword=( + ( + (* nibble 0 *) + $02080800, $00080000, $02000002, $02080802, + $02000000, $00080802, $00080002, $02000002, + $00080802, $02080800, $02080000, $00000802, + $02000802, $02000000, $00000000, $00080002, + $00080000, $00000002, $02000800, $00080800, + $02080802, $02080000, $00000802, $02000800, + $00000002, $00000800, $00080800, $02080002, + $00000800, $02000802, $02080002, $00000000, + $00000000, $02080802, $02000800, $00080002, + $02080800, $00080000, $00000802, $02000800, + $02080002, $00000800, $00080800, $02000002, + $00080802, $00000002, $02000002, $02080000, + $02080802, $00080800, $02080000, $02000802, + $02000000, $00000802, $00080002, $00000000, + $00080000, $02000000, $02000802, $02080800, + $00000002, $02080002, $00000800, $00080802 + ),( + (* nibble 1 *) + $40108010, $00000000, $00108000, $40100000, + $40000010, $00008010, $40008000, $00108000, + $00008000, $40100010, $00000010, $40008000, + $00100010, $40108000, $40100000, $00000010, + $00100000, $40008010, $40100010, $00008000, + $00108010, $40000000, $00000000, $00100010, + $40008010, $00108010, $40108000, $40000010, + $40000000, $00100000, $00008010, $40108010, + $00100010, $40108000, $40008000, $00108010, + $40108010, $00100010, $40000010, $00000000, + $40000000, $00008010, $00100000, $40100010, + $00008000, $40000000, $00108010, $40008010, + $40108000, $00008000, $00000000, $40000010, + $00000010, $40108010, $00108000, $40100000, + $40100010, $00100000, $00008010, $40008000, + $40008010, $00000010, $40100000, $00108000 + ),( + (* nibble 2 *) + $04000001, $04040100, $00000100, $04000101, + $00040001, $04000000, $04000101, $00040100, + $04000100, $00040000, $04040000, $00000001, + $04040101, $00000101, $00000001, $04040001, + $00000000, $00040001, $04040100, $00000100, + $00000101, $04040101, $00040000, $04000001, + $04040001, $04000100, $00040101, $04040000, + $00040100, $00000000, $04000000, $00040101, + $04040100, $00000100, $00000001, $00040000, + $00000101, $00040001, $04040000, $04000101, + $00000000, $04040100, $00040100, $04040001, + $00040001, $04000000, $04040101, $00000001, + $00040101, $04000001, $04000000, $04040101, + $00040000, $04000100, $04000101, $00040100, + $04000100, $00000000, $04040001, $00000101, + $04000001, $00040101, $00000100, $04040000 + ),( + (* nibble 3 *) + $00401008, $10001000, $00000008, $10401008, + $00000000, $10400000, $10001008, $00400008, + $10401000, $10000008, $10000000, $00001008, + $10000008, $00401008, $00400000, $10000000, + $10400008, $00401000, $00001000, $00000008, + $00401000, $10001008, $10400000, $00001000, + $00001008, $00000000, $00400008, $10401000, + $10001000, $10400008, $10401008, $00400000, + $10400008, $00001008, $00400000, $10000008, + $00401000, $10001000, $00000008, $10400000, + $10001008, $00000000, $00001000, $00400008, + $00000000, $10400008, $10401000, $00001000, + $10000000, $10401008, $00401008, $00400000, + $10401008, $00000008, $10001000, $00401008, + $00400008, $00401000, $10400000, $10001008, + $00001008, $10000000, $10000008, $10401000 + ),( + (* nibble 4 *) + $08000000, $00010000, $00000400, $08010420, + $08010020, $08000400, $00010420, $08010000, + $00010000, $00000020, $08000020, $00010400, + $08000420, $08010020, $08010400, $00000000, + $00010400, $08000000, $00010020, $00000420, + $08000400, $00010420, $00000000, $08000020, + $00000020, $08000420, $08010420, $00010020, + $08010000, $00000400, $00000420, $08010400, + $08010400, $08000420, $00010020, $08010000, + $00010000, $00000020, $08000020, $08000400, + $08000000, $00010400, $08010420, $00000000, + $00010420, $08000000, $00000400, $00010020, + $08000420, $00000400, $00000000, $08010420, + $08010020, $08010400, $00000420, $00010000, + $00010400, $08010020, $08000400, $00000420, + $00000020, $00010420, $08010000, $08000020 + ),( + (* nibble 5 *) + $80000040, $00200040, $00000000, $80202000, + $00200040, $00002000, $80002040, $00200000, + $00002040, $80202040, $00202000, $80000000, + $80002000, $80000040, $80200000, $00202040, + $00200000, $80002040, $80200040, $00000000, + $00002000, $00000040, $80202000, $80200040, + $80202040, $80200000, $80000000, $00002040, + $00000040, $00202000, $00202040, $80002000, + $00002040, $80000000, $80002000, $00202040, + $80202000, $00200040, $00000000, $80002000, + $80000000, $00002000, $80200040, $00200000, + $00200040, $80202040, $00202000, $00000040, + $80202040, $00202000, $00200000, $80002040, + $80000040, $80200000, $00202040, $00000000, + $00002000, $80000040, $80002040, $80202000, + $80200000, $00002040, $00000040, $80200040 + ),( + (* nibble 6 *) + $00004000, $00000200, $01000200, $01000004, + $01004204, $00004004, $00004200, $00000000, + $01000000, $01000204, $00000204, $01004000, + $00000004, $01004200, $01004000, $00000204, + $01000204, $00004000, $00004004, $01004204, + $00000000, $01000200, $01000004, $00004200, + $01004004, $00004204, $01004200, $00000004, + $00004204, $01004004, $00000200, $01000000, + $00004204, $01004000, $01004004, $00000204, + $00004000, $00000200, $01000000, $01004004, + $01000204, $00004204, $00004200, $00000000, + $00000200, $01000004, $00000004, $01000200, + $00000000, $01000204, $01000200, $00004200, + $00000204, $00004000, $01004204, $01000000, + $01004200, $00000004, $00004004, $01004204, + $01000004, $01004200, $01004000, $00004004 + ),( + (* nibble 7 *) + $20800080, $20820000, $00020080, $00000000, + $20020000, $00800080, $20800000, $20820080, + $00000080, $20000000, $00820000, $00020080, + $00820080, $20020080, $20000080, $20800000, + $00020000, $00820080, $00800080, $20020000, + $20820080, $20000080, $00000000, $00820000, + $20000000, $00800000, $20020080, $20800080, + $00800000, $00020000, $20820000, $00000080, + $00800000, $00020000, $20000080, $20820080, + $00020080, $20000000, $00000000, $00820000, + $20800080, $20020080, $20020000, $00800080, + $20820000, $00000080, $00800080, $20020000, + $20820080, $00800000, $20800000, $20000080, + $00820000, $00020080, $20020080, $20800000, + $00000080, $20820000, $00820080, $00000000, + $20000000, $20800080, $00020000, $00820080 + )); + +// DES and 3DES cipher implementation +type + Pdwordarray= ^Tdwordarray; + Tdwordarray= array[0..8191] of dword; + +type + TCustomDES = object(TBlockCipher64) + protected + procedure DoInit(KeyB: PByteArray; KeyData: PDWordArray);virtual; + procedure EncryptBlock(const InData; var OutData; KeyData: PDWordArray); + procedure DecryptBlock(const InData; var OutData; KeyData: PDWordArray); + end; + +type + PDES = ^TDES; + TDES = object (TCustomDES) + protected + KeyData: array[0..31] of dword; + public + procedure InitKey(const Key; Size: longword);virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + +type + P3DES = ^T3DES; + T3DES = object (TCustomDES) + protected + KeyData: array[0..2,0..31] of dword; + public + procedure InitKey(const Key; Size: longword);virtual; + procedure Burn;virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + + +type + Pwordarray= ^Twordarray; + Twordarray= array[0..19383] of word; + + +// ICE, ICE2 and ThinICE cipher implementation +type + TCustomICE= object(TBlockCipher64) + protected + rounds: dword; + ik_keysched: array[0..31,0..2] of dword; + function f(p, sk: dword): dword; + procedure key_sched_build(kb: pwordarray; n: dword; keyrot: pdwordarray); + procedure InitIce(const Key; Size: longword; n: dword); + public + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + end; + +type + PICE = ^TICE; + TICE = object(TCustomICE) + protected + public + procedure InitKey(const Key; Size: longword); virtual; + + destructor Destroy; virtual; + end; + +type + PThinIce = ^TThinIce; + TThinIce= object(TCustomICE) + protected + + public + procedure InitKey(const Key; Size: longword); virtual; + + destructor Destroy; virtual; + end; + +type + PICE2 = ^TICE2; + TICE2= object(TCustomICE) + protected + + public + procedure InitKey(const Key; Size: longword); virtual; + + destructor Destroy; virtual; + end; + + +// Mars cipher implementation +const + S_Box: array[0..511] of DWord= ( + $09d0c479, $28c8ffe0, $84aa6c39, $9dad7287, + $7dff9be3, $d4268361, $c96da1d4, $7974cc93, + $85d0582e, $2a4b5705, $1ca16a62, $c3bd279d, + $0f1f25e5, $5160372f, $c695c1fb, $4d7ff1e4, + $ae5f6bf4, $0d72ee46, $ff23de8a, $b1cf8e83, + $f14902e2, $3e981e42, $8bf53eb6, $7f4bf8ac, + $83631f83, $25970205, $76afe784, $3a7931d4, + $4f846450, $5c64c3f6, $210a5f18, $c6986a26, + $28f4e826, $3a60a81c, $d340a664, $7ea820c4, + $526687c5, $7eddd12b, $32a11d1d, $9c9ef086, + $80f6e831, $ab6f04ad, $56fb9b53, $8b2e095c, + $b68556ae, $d2250b0d, $294a7721, $e21fb253, + $ae136749, $e82aae86, $93365104, $99404a66, + $78a784dc, $b69ba84b, $04046793, $23db5c1e, + $46cae1d6, $2fe28134, $5a223942, $1863cd5b, + $c190c6e3, $07dfb846, $6eb88816, $2d0dcc4a, + $a4ccae59, $3798670d, $cbfa9493, $4f481d45, + $eafc8ca8, $db1129d6, $b0449e20, $0f5407fb, + $6167d9a8, $d1f45763, $4daa96c3, $3bec5958, + $ababa014, $b6ccd201, $38d6279f, $02682215, + $8f376cd5, $092c237e, $bfc56593, $32889d2c, + $854b3e95, $05bb9b43, $7dcd5dcd, $a02e926c, + $fae527e5, $36a1c330, $3412e1ae, $f257f462, + $3c4f1d71, $30a2e809, $68e5f551, $9c61ba44, + $5ded0ab8, $75ce09c8, $9654f93e, $698c0cca, + $243cb3e4, $2b062b97, $0f3b8d9e, $00e050df, + $fc5d6166, $e35f9288, $c079550d, $0591aee8, + $8e531e74, $75fe3578, $2f6d829a, $f60b21ae, + $95e8eb8d, $6699486b, $901d7d9b, $fd6d6e31, + $1090acef, $e0670dd8, $dab2e692, $cd6d4365, + $e5393514, $3af345f0, $6241fc4d, $460da3a3, + $7bcf3729, $8bf1d1e0, $14aac070, $1587ed55, + $3afd7d3e, $d2f29e01, $29a9d1f6, $efb10c53, + $cf3b870f, $b414935c, $664465ed, $024acac7, + $59a744c1, $1d2936a7, $dc580aa6, $cf574ca8, + $040a7a10, $6cd81807, $8a98be4c, $accea063, + $c33e92b5, $d1e0e03d, $b322517e, $2092bd13, + $386b2c4a, $52e8dd58, $58656dfb, $50820371, + $41811896, $e337ef7e, $d39fb119, $c97f0df6, + $68fea01b, $a150a6e5, $55258962, $eb6ff41b, + $d7c9cd7a, $a619cd9e, $bcf09576, $2672c073, + $f003fb3c, $4ab7a50b, $1484126a, $487ba9b1, + $a64fc9c6, $f6957d49, $38b06a75, $dd805fcd, + $63d094cf, $f51c999e, $1aa4d343, $b8495294, + $ce9f8e99, $bffcd770, $c7c275cc, $378453a7, + $7b21be33, $397f41bd, $4e94d131, $92cc1f98, + $5915ea51, $99f861b7, $c9980a88, $1d74fd5f, + $b0a495f8, $614deed0, $b5778eea, $5941792d, + $fa90c1f8, $33f824b4, $c4965372, $3ff6d550, + $4ca5fec0, $8630e964, $5b3fbbd6, $7da26a48, + $b203231a, $04297514, $2d639306, $2eb13149, + $16a45272, $532459a0, $8e5f4872, $f966c7d9, + $07128dc0, $0d44db62, $afc8d52d, $06316131, + $d838e7ce, $1bc41d00, $3a2e8c0f, $ea83837e, + $b984737d, $13ba4891, $c4f8b949, $a6d6acb3, + $a215cdce, $8359838b, $6bd1aa31, $f579dd52, + $21b93f93, $f5176781, $187dfdde, $e94aeb76, + $2b38fd54, $431de1da, $ab394825, $9ad3048f, + $dfea32aa, $659473e3, $623f7863, $f3346c59, + $ab3ab685, $3346a90b, $6b56443e, $c6de01f8, + $8d421fc0, $9b0ed10c, $88f1a1e9, $54c1f029, + $7dead57b, $8d7ba426, $4cf5178a, $551a7cca, + $1a9a5f08, $fcd651b9, $25605182, $e11fc6c3, + $b6fd9676, $337b3027, $b7c8eb14, $9e5fd030, + $6b57e354, $ad913cf7, $7e16688d, $58872a69, + $2c2fc7df, $e389ccc6, $30738df1, $0824a734, + $e1797a8b, $a4a8d57b, $5b5d193b, $c8a8309b, + $73f9a978, $73398d32, $0f59573e, $e9df2b03, + $e8a5b6c8, $848d0704, $98df93c2, $720a1dc3, + $684f259a, $943ba848, $a6370152, $863b5ea3, + $d17b978b, $6d9b58ef, $0a700dd4, $a73d36bf, + $8e6a0829, $8695bc14, $e35b3447, $933ac568, + $8894b022, $2f511c27, $ddfbcc3c, $006662b6, + $117c83fe, $4e12b414, $c2bca766, $3a2fec10, + $f4562420, $55792e2a, $46f5d857, $ceda25ce, + $c3601d3b, $6c00ab46, $efac9c28, $b3c35047, + $611dfee3, $257c3207, $fdd58482, $3b14d84f, + $23becb64, $a075f3a3, $088f8ead, $07adf158, + $7796943c, $facabf3d, $c09730cd, $f7679969, + $da44e9ed, $2c854c12, $35935fa3, $2f057d9f, + $690624f8, $1cb0bafd, $7b0dbdc6, $810f23bb, + $fa929a1a, $6d969a17, $6742979b, $74ac7d05, + $010e65c4, $86a3d963, $f907b5a0, $d0042bd3, + $158d7d03, $287a8255, $bba8366f, $096edc33, + $21916a7b, $77b56b86, $951622f9, $a6c5e650, + $8cea17d1, $cd8c62bc, $a3d63433, $358a68fd, + $0f9b9d3c, $d6aa295b, $fe33384a, $c000738e, + $cd67eb2f, $e2eb6dc2, $97338b02, $06c9f246, + $419cf1ad, $2b83c045, $3723f18a, $cb5b3089, + $160bead7, $5d494656, $35f8a74b, $1e4e6c9e, + $000399bd, $67466880, $b4174831, $acf423b2, + $ca815ab3, $5a6395e7, $302a67c5, $8bdb446b, + $108f8fa4, $10223eda, $92b8b48b, $7f38d0ee, + $ab2701d4, $0262d415, $af224a30, $b3d88aba, + $f8b2c3af, $daf7ef70, $cc97d3b7, $e9614b6c, + $2baebff4, $70f687cf, $386c9156, $ce092ee5, + $01e87da6, $6ce91e6a, $bb7bcc84, $c7922c20, + $9d3b71fd, $060e41c6, $d7590f15, $4e03bb47, + $183c198e, $63eeb240, $2ddbf49a, $6d5cba54, + $923750af, $f9e14236, $7838162b, $59726c72, + $81b66760, $bb2926c1, $48a0ce0d, $a6c0496d, + $ad43507b, $718d496a, $9df057af, $44b1bde6, + $054356dc, $de7ced35, $d51a138b, $62088cc9, + $35830311, $c96efca2, $686f86ec, $8e77cb68, + $63e1d6b8, $c80f9778, $79c491fd, $1b4c67f2, + $72698d7d, $5e368c31, $f7d95e2e, $a1d3493f, + $dcd9433e, $896f1552, $4bc4ca7a, $a6d1baf4, + $a5a96dcc, $0bef8b46, $a169fda7, $74df40b7, + $4e208804, $9a756607, $038e87c8, $20211e44, + $8b7ad4bf, $c6403f35, $1848e36d, $80bdb038, + $1e62891c, $643d2107, $bf04d6f8, $21092c8c, + $f644f389, $0778404e, $7b78adb8, $a2c52d53, + $42157abe, $a2253e2e, $7bf3f4ae, $80f594f9, + $953194e7, $77eb92ed, $b3816930, $da8d9336, + $bf447469, $f26d9483, $ee6faed5, $71371235, + $de425f73, $b4e59f43, $7dbe2d4e, $2d37b185, + $49dc9a63, $98c39d98, $1301c9a2, $389b1bbf, + $0c18588d, $a421c1ba, $7aa3865c, $71e08558, + $3c5cfcaa, $7d239ca4, $0297d9dd, $d7dc2830, + $4b37802b, $7428ab54, $aeee0347, $4b3fbb85, + $692f2f08, $134e578e, $36d9e0bf, $ae8b5fcf, + $edb93ecf, $2b27248e, $170eb1ef, $7dc57fd6, + $1e760f16, $b1136601, $864e1b9b, $d7ea7319, + $3ab871bd, $cfa4d76f, $e31bd782, $0dbeb469, + $abb96061, $5370f85d, $ffb07e37, $da30d0fb, + $ebc977b6, $0b98b40f, $3a4d0fe6, $df4fc26b, + $159cf22a, $c298d6e2, $2b78ef6a, $61a94ac0, + $ab561187, $14eea0f0, $df0d4164, $19af70ee); + + vk: array[0..6] of DWord= ( + $09d0c479, $28c8ffe0, $84aa6c39, $9dad7287, $7dff9be3, $d4268361, + $c96da1d4); + +type + PMars = ^TMars; + TMars = object(TBlockCipher128) + protected + KeyData: array[0..39] of DWord; + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + +// Rijndael cipher implementation +const + MAXBC= 8; + MAXKC= 8; + + S: array[0..255] of byte= ( + 99, 124, 119, 123, 242, 107, 111, 197, 48, 1, 103, 43, 254, 215, 171, 118, + 202, 130, 201, 125, 250, 89, 71, 240, 173, 212, 162, 175, 156, 164, 114, 192, + 183, 253, 147, 38, 54, 63, 247, 204, 52, 165, 229, 241, 113, 216, 49, 21, + 4, 199, 35, 195, 24, 150, 5, 154, 7, 18, 128, 226, 235, 39, 178, 117, + 9, 131, 44, 26, 27, 110, 90, 160, 82, 59, 214, 179, 41, 227, 47, 132, + 83, 209, 0, 237, 32, 252, 177, 91, 106, 203, 190, 57, 74, 76, 88, 207, + 208, 239, 170, 251, 67, 77, 51, 133, 69, 249, 2, 127, 80, 60, 159, 168, + 81, 163, 64, 143, 146, 157, 56, 245, 188, 182, 218, 33, 16, 255, 243, 210, + 205, 12, 19, 236, 95, 151, 68, 23, 196, 167, 126, 61, 100, 93, 25, 115, + 96, 129, 79, 220, 34, 42, 144, 136, 70, 238, 184, 20, 222, 94, 11, 219, + 224, 50, 58, 10, 73, 6, 36, 92, 194, 211, 172, 98, 145, 149, 228, 121, + 231, 200, 55, 109, 141, 213, 78, 169, 108, 86, 244, 234, 101, 122, 174, 8, + 186, 120, 37, 46, 28, 166, 180, 198, 232, 221, 116, 31, 75, 189, 139, 138, + 112, 62, 181, 102, 72, 3, 246, 14, 97, 53, 87, 185, 134, 193, 29, 158, + 225, 248, 152, 17, 105, 217, 142, 148, 155, 30, 135, 233, 206, 85, 40, 223, + 140, 161, 137, 13, 191, 230, 66, 104, 65, 153, 45, 15, 176, 84, 187, 22); + T1: array[0..255,0..3] of byte= ( + ($c6,$63,$63,$a5), ($f8,$7c,$7c,$84), ($ee,$77,$77,$99), ($f6,$7b,$7b,$8d), + ($ff,$f2,$f2,$0d), ($d6,$6b,$6b,$bd), ($de,$6f,$6f,$b1), ($91,$c5,$c5,$54), + ($60,$30,$30,$50), ($02,$01,$01,$03), ($ce,$67,$67,$a9), ($56,$2b,$2b,$7d), + ($e7,$fe,$fe,$19), ($b5,$d7,$d7,$62), ($4d,$ab,$ab,$e6), ($ec,$76,$76,$9a), + ($8f,$ca,$ca,$45), ($1f,$82,$82,$9d), ($89,$c9,$c9,$40), ($fa,$7d,$7d,$87), + ($ef,$fa,$fa,$15), ($b2,$59,$59,$eb), ($8e,$47,$47,$c9), ($fb,$f0,$f0,$0b), + ($41,$ad,$ad,$ec), ($b3,$d4,$d4,$67), ($5f,$a2,$a2,$fd), ($45,$af,$af,$ea), + ($23,$9c,$9c,$bf), ($53,$a4,$a4,$f7), ($e4,$72,$72,$96), ($9b,$c0,$c0,$5b), + ($75,$b7,$b7,$c2), ($e1,$fd,$fd,$1c), ($3d,$93,$93,$ae), ($4c,$26,$26,$6a), + ($6c,$36,$36,$5a), ($7e,$3f,$3f,$41), ($f5,$f7,$f7,$02), ($83,$cc,$cc,$4f), + ($68,$34,$34,$5c), ($51,$a5,$a5,$f4), ($d1,$e5,$e5,$34), ($f9,$f1,$f1,$08), + ($e2,$71,$71,$93), ($ab,$d8,$d8,$73), ($62,$31,$31,$53), ($2a,$15,$15,$3f), + ($08,$04,$04,$0c), ($95,$c7,$c7,$52), ($46,$23,$23,$65), ($9d,$c3,$c3,$5e), + ($30,$18,$18,$28), ($37,$96,$96,$a1), ($0a,$05,$05,$0f), ($2f,$9a,$9a,$b5), + ($0e,$07,$07,$09), ($24,$12,$12,$36), ($1b,$80,$80,$9b), ($df,$e2,$e2,$3d), + ($cd,$eb,$eb,$26), ($4e,$27,$27,$69), ($7f,$b2,$b2,$cd), ($ea,$75,$75,$9f), + ($12,$09,$09,$1b), ($1d,$83,$83,$9e), ($58,$2c,$2c,$74), ($34,$1a,$1a,$2e), + ($36,$1b,$1b,$2d), ($dc,$6e,$6e,$b2), ($b4,$5a,$5a,$ee), ($5b,$a0,$a0,$fb), + ($a4,$52,$52,$f6), ($76,$3b,$3b,$4d), ($b7,$d6,$d6,$61), ($7d,$b3,$b3,$ce), + ($52,$29,$29,$7b), ($dd,$e3,$e3,$3e), ($5e,$2f,$2f,$71), ($13,$84,$84,$97), + ($a6,$53,$53,$f5), ($b9,$d1,$d1,$68), ($00,$00,$00,$00), ($c1,$ed,$ed,$2c), + ($40,$20,$20,$60), ($e3,$fc,$fc,$1f), ($79,$b1,$b1,$c8), ($b6,$5b,$5b,$ed), + ($d4,$6a,$6a,$be), ($8d,$cb,$cb,$46), ($67,$be,$be,$d9), ($72,$39,$39,$4b), + ($94,$4a,$4a,$de), ($98,$4c,$4c,$d4), ($b0,$58,$58,$e8), ($85,$cf,$cf,$4a), + ($bb,$d0,$d0,$6b), ($c5,$ef,$ef,$2a), ($4f,$aa,$aa,$e5), ($ed,$fb,$fb,$16), + ($86,$43,$43,$c5), ($9a,$4d,$4d,$d7), ($66,$33,$33,$55), ($11,$85,$85,$94), + ($8a,$45,$45,$cf), ($e9,$f9,$f9,$10), ($04,$02,$02,$06), ($fe,$7f,$7f,$81), + ($a0,$50,$50,$f0), ($78,$3c,$3c,$44), ($25,$9f,$9f,$ba), ($4b,$a8,$a8,$e3), + ($a2,$51,$51,$f3), ($5d,$a3,$a3,$fe), ($80,$40,$40,$c0), ($05,$8f,$8f,$8a), + ($3f,$92,$92,$ad), ($21,$9d,$9d,$bc), ($70,$38,$38,$48), ($f1,$f5,$f5,$04), + ($63,$bc,$bc,$df), ($77,$b6,$b6,$c1), ($af,$da,$da,$75), ($42,$21,$21,$63), + ($20,$10,$10,$30), ($e5,$ff,$ff,$1a), ($fd,$f3,$f3,$0e), ($bf,$d2,$d2,$6d), + ($81,$cd,$cd,$4c), ($18,$0c,$0c,$14), ($26,$13,$13,$35), ($c3,$ec,$ec,$2f), + ($be,$5f,$5f,$e1), ($35,$97,$97,$a2), ($88,$44,$44,$cc), ($2e,$17,$17,$39), + ($93,$c4,$c4,$57), ($55,$a7,$a7,$f2), ($fc,$7e,$7e,$82), ($7a,$3d,$3d,$47), + ($c8,$64,$64,$ac), ($ba,$5d,$5d,$e7), ($32,$19,$19,$2b), ($e6,$73,$73,$95), + ($c0,$60,$60,$a0), ($19,$81,$81,$98), ($9e,$4f,$4f,$d1), ($a3,$dc,$dc,$7f), + ($44,$22,$22,$66), ($54,$2a,$2a,$7e), ($3b,$90,$90,$ab), ($0b,$88,$88,$83), + ($8c,$46,$46,$ca), ($c7,$ee,$ee,$29), ($6b,$b8,$b8,$d3), ($28,$14,$14,$3c), + ($a7,$de,$de,$79), ($bc,$5e,$5e,$e2), ($16,$0b,$0b,$1d), ($ad,$db,$db,$76), + ($db,$e0,$e0,$3b), ($64,$32,$32,$56), ($74,$3a,$3a,$4e), ($14,$0a,$0a,$1e), + ($92,$49,$49,$db), ($0c,$06,$06,$0a), ($48,$24,$24,$6c), ($b8,$5c,$5c,$e4), + ($9f,$c2,$c2,$5d), ($bd,$d3,$d3,$6e), ($43,$ac,$ac,$ef), ($c4,$62,$62,$a6), + ($39,$91,$91,$a8), ($31,$95,$95,$a4), ($d3,$e4,$e4,$37), ($f2,$79,$79,$8b), + ($d5,$e7,$e7,$32), ($8b,$c8,$c8,$43), ($6e,$37,$37,$59), ($da,$6d,$6d,$b7), + ($01,$8d,$8d,$8c), ($b1,$d5,$d5,$64), ($9c,$4e,$4e,$d2), ($49,$a9,$a9,$e0), + ($d8,$6c,$6c,$b4), ($ac,$56,$56,$fa), ($f3,$f4,$f4,$07), ($cf,$ea,$ea,$25), + ($ca,$65,$65,$af), ($f4,$7a,$7a,$8e), ($47,$ae,$ae,$e9), ($10,$08,$08,$18), + ($6f,$ba,$ba,$d5), ($f0,$78,$78,$88), ($4a,$25,$25,$6f), ($5c,$2e,$2e,$72), + ($38,$1c,$1c,$24), ($57,$a6,$a6,$f1), ($73,$b4,$b4,$c7), ($97,$c6,$c6,$51), + ($cb,$e8,$e8,$23), ($a1,$dd,$dd,$7c), ($e8,$74,$74,$9c), ($3e,$1f,$1f,$21), + ($96,$4b,$4b,$dd), ($61,$bd,$bd,$dc), ($0d,$8b,$8b,$86), ($0f,$8a,$8a,$85), + ($e0,$70,$70,$90), ($7c,$3e,$3e,$42), ($71,$b5,$b5,$c4), ($cc,$66,$66,$aa), + ($90,$48,$48,$d8), ($06,$03,$03,$05), ($f7,$f6,$f6,$01), ($1c,$0e,$0e,$12), + ($c2,$61,$61,$a3), ($6a,$35,$35,$5f), ($ae,$57,$57,$f9), ($69,$b9,$b9,$d0), + ($17,$86,$86,$91), ($99,$c1,$c1,$58), ($3a,$1d,$1d,$27), ($27,$9e,$9e,$b9), + ($d9,$e1,$e1,$38), ($eb,$f8,$f8,$13), ($2b,$98,$98,$b3), ($22,$11,$11,$33), + ($d2,$69,$69,$bb), ($a9,$d9,$d9,$70), ($07,$8e,$8e,$89), ($33,$94,$94,$a7), + ($2d,$9b,$9b,$b6), ($3c,$1e,$1e,$22), ($15,$87,$87,$92), ($c9,$e9,$e9,$20), + ($87,$ce,$ce,$49), ($aa,$55,$55,$ff), ($50,$28,$28,$78), ($a5,$df,$df,$7a), + ($03,$8c,$8c,$8f), ($59,$a1,$a1,$f8), ($09,$89,$89,$80), ($1a,$0d,$0d,$17), + ($65,$bf,$bf,$da), ($d7,$e6,$e6,$31), ($84,$42,$42,$c6), ($d0,$68,$68,$b8), + ($82,$41,$41,$c3), ($29,$99,$99,$b0), ($5a,$2d,$2d,$77), ($1e,$0f,$0f,$11), + ($7b,$b0,$b0,$cb), ($a8,$54,$54,$fc), ($6d,$bb,$bb,$d6), ($2c,$16,$16,$3a)); + T2: array[0..255,0..3] of byte= ( + ($a5,$c6,$63,$63), ($84,$f8,$7c,$7c), ($99,$ee,$77,$77), ($8d,$f6,$7b,$7b), + ($0d,$ff,$f2,$f2), ($bd,$d6,$6b,$6b), ($b1,$de,$6f,$6f), ($54,$91,$c5,$c5), + ($50,$60,$30,$30), ($03,$02,$01,$01), ($a9,$ce,$67,$67), ($7d,$56,$2b,$2b), + ($19,$e7,$fe,$fe), ($62,$b5,$d7,$d7), ($e6,$4d,$ab,$ab), ($9a,$ec,$76,$76), + ($45,$8f,$ca,$ca), ($9d,$1f,$82,$82), ($40,$89,$c9,$c9), ($87,$fa,$7d,$7d), + ($15,$ef,$fa,$fa), ($eb,$b2,$59,$59), ($c9,$8e,$47,$47), ($0b,$fb,$f0,$f0), + ($ec,$41,$ad,$ad), ($67,$b3,$d4,$d4), ($fd,$5f,$a2,$a2), ($ea,$45,$af,$af), + ($bf,$23,$9c,$9c), ($f7,$53,$a4,$a4), ($96,$e4,$72,$72), ($5b,$9b,$c0,$c0), + ($c2,$75,$b7,$b7), ($1c,$e1,$fd,$fd), ($ae,$3d,$93,$93), ($6a,$4c,$26,$26), + ($5a,$6c,$36,$36), ($41,$7e,$3f,$3f), ($02,$f5,$f7,$f7), ($4f,$83,$cc,$cc), + ($5c,$68,$34,$34), ($f4,$51,$a5,$a5), ($34,$d1,$e5,$e5), ($08,$f9,$f1,$f1), + ($93,$e2,$71,$71), ($73,$ab,$d8,$d8), ($53,$62,$31,$31), ($3f,$2a,$15,$15), + ($0c,$08,$04,$04), ($52,$95,$c7,$c7), ($65,$46,$23,$23), ($5e,$9d,$c3,$c3), + ($28,$30,$18,$18), ($a1,$37,$96,$96), ($0f,$0a,$05,$05), ($b5,$2f,$9a,$9a), + ($09,$0e,$07,$07), ($36,$24,$12,$12), ($9b,$1b,$80,$80), ($3d,$df,$e2,$e2), + ($26,$cd,$eb,$eb), ($69,$4e,$27,$27), ($cd,$7f,$b2,$b2), ($9f,$ea,$75,$75), + ($1b,$12,$09,$09), ($9e,$1d,$83,$83), ($74,$58,$2c,$2c), ($2e,$34,$1a,$1a), + ($2d,$36,$1b,$1b), ($b2,$dc,$6e,$6e), ($ee,$b4,$5a,$5a), ($fb,$5b,$a0,$a0), + ($f6,$a4,$52,$52), ($4d,$76,$3b,$3b), ($61,$b7,$d6,$d6), ($ce,$7d,$b3,$b3), + ($7b,$52,$29,$29), ($3e,$dd,$e3,$e3), ($71,$5e,$2f,$2f), ($97,$13,$84,$84), + ($f5,$a6,$53,$53), ($68,$b9,$d1,$d1), ($00,$00,$00,$00), ($2c,$c1,$ed,$ed), + ($60,$40,$20,$20), ($1f,$e3,$fc,$fc), ($c8,$79,$b1,$b1), ($ed,$b6,$5b,$5b), + ($be,$d4,$6a,$6a), ($46,$8d,$cb,$cb), ($d9,$67,$be,$be), ($4b,$72,$39,$39), + ($de,$94,$4a,$4a), ($d4,$98,$4c,$4c), ($e8,$b0,$58,$58), ($4a,$85,$cf,$cf), + ($6b,$bb,$d0,$d0), ($2a,$c5,$ef,$ef), ($e5,$4f,$aa,$aa), ($16,$ed,$fb,$fb), + ($c5,$86,$43,$43), ($d7,$9a,$4d,$4d), ($55,$66,$33,$33), ($94,$11,$85,$85), + ($cf,$8a,$45,$45), ($10,$e9,$f9,$f9), ($06,$04,$02,$02), ($81,$fe,$7f,$7f), + ($f0,$a0,$50,$50), ($44,$78,$3c,$3c), ($ba,$25,$9f,$9f), ($e3,$4b,$a8,$a8), + ($f3,$a2,$51,$51), ($fe,$5d,$a3,$a3), ($c0,$80,$40,$40), ($8a,$05,$8f,$8f), + ($ad,$3f,$92,$92), ($bc,$21,$9d,$9d), ($48,$70,$38,$38), ($04,$f1,$f5,$f5), + ($df,$63,$bc,$bc), ($c1,$77,$b6,$b6), ($75,$af,$da,$da), ($63,$42,$21,$21), + ($30,$20,$10,$10), ($1a,$e5,$ff,$ff), ($0e,$fd,$f3,$f3), ($6d,$bf,$d2,$d2), + ($4c,$81,$cd,$cd), ($14,$18,$0c,$0c), ($35,$26,$13,$13), ($2f,$c3,$ec,$ec), + ($e1,$be,$5f,$5f), ($a2,$35,$97,$97), ($cc,$88,$44,$44), ($39,$2e,$17,$17), + ($57,$93,$c4,$c4), ($f2,$55,$a7,$a7), ($82,$fc,$7e,$7e), ($47,$7a,$3d,$3d), + ($ac,$c8,$64,$64), ($e7,$ba,$5d,$5d), ($2b,$32,$19,$19), ($95,$e6,$73,$73), + ($a0,$c0,$60,$60), ($98,$19,$81,$81), ($d1,$9e,$4f,$4f), ($7f,$a3,$dc,$dc), + ($66,$44,$22,$22), ($7e,$54,$2a,$2a), ($ab,$3b,$90,$90), ($83,$0b,$88,$88), + ($ca,$8c,$46,$46), ($29,$c7,$ee,$ee), ($d3,$6b,$b8,$b8), ($3c,$28,$14,$14), + ($79,$a7,$de,$de), ($e2,$bc,$5e,$5e), ($1d,$16,$0b,$0b), ($76,$ad,$db,$db), + ($3b,$db,$e0,$e0), ($56,$64,$32,$32), ($4e,$74,$3a,$3a), ($1e,$14,$0a,$0a), + ($db,$92,$49,$49), ($0a,$0c,$06,$06), ($6c,$48,$24,$24), ($e4,$b8,$5c,$5c), + ($5d,$9f,$c2,$c2), ($6e,$bd,$d3,$d3), ($ef,$43,$ac,$ac), ($a6,$c4,$62,$62), + ($a8,$39,$91,$91), ($a4,$31,$95,$95), ($37,$d3,$e4,$e4), ($8b,$f2,$79,$79), + ($32,$d5,$e7,$e7), ($43,$8b,$c8,$c8), ($59,$6e,$37,$37), ($b7,$da,$6d,$6d), + ($8c,$01,$8d,$8d), ($64,$b1,$d5,$d5), ($d2,$9c,$4e,$4e), ($e0,$49,$a9,$a9), + ($b4,$d8,$6c,$6c), ($fa,$ac,$56,$56), ($07,$f3,$f4,$f4), ($25,$cf,$ea,$ea), + ($af,$ca,$65,$65), ($8e,$f4,$7a,$7a), ($e9,$47,$ae,$ae), ($18,$10,$08,$08), + ($d5,$6f,$ba,$ba), ($88,$f0,$78,$78), ($6f,$4a,$25,$25), ($72,$5c,$2e,$2e), + ($24,$38,$1c,$1c), ($f1,$57,$a6,$a6), ($c7,$73,$b4,$b4), ($51,$97,$c6,$c6), + ($23,$cb,$e8,$e8), ($7c,$a1,$dd,$dd), ($9c,$e8,$74,$74), ($21,$3e,$1f,$1f), + ($dd,$96,$4b,$4b), ($dc,$61,$bd,$bd), ($86,$0d,$8b,$8b), ($85,$0f,$8a,$8a), + ($90,$e0,$70,$70), ($42,$7c,$3e,$3e), ($c4,$71,$b5,$b5), ($aa,$cc,$66,$66), + ($d8,$90,$48,$48), ($05,$06,$03,$03), ($01,$f7,$f6,$f6), ($12,$1c,$0e,$0e), + ($a3,$c2,$61,$61), ($5f,$6a,$35,$35), ($f9,$ae,$57,$57), ($d0,$69,$b9,$b9), + ($91,$17,$86,$86), ($58,$99,$c1,$c1), ($27,$3a,$1d,$1d), ($b9,$27,$9e,$9e), + ($38,$d9,$e1,$e1), ($13,$eb,$f8,$f8), ($b3,$2b,$98,$98), ($33,$22,$11,$11), + ($bb,$d2,$69,$69), ($70,$a9,$d9,$d9), ($89,$07,$8e,$8e), ($a7,$33,$94,$94), + ($b6,$2d,$9b,$9b), ($22,$3c,$1e,$1e), ($92,$15,$87,$87), ($20,$c9,$e9,$e9), + ($49,$87,$ce,$ce), ($ff,$aa,$55,$55), ($78,$50,$28,$28), ($7a,$a5,$df,$df), + ($8f,$03,$8c,$8c), ($f8,$59,$a1,$a1), ($80,$09,$89,$89), ($17,$1a,$0d,$0d), + ($da,$65,$bf,$bf), ($31,$d7,$e6,$e6), ($c6,$84,$42,$42), ($b8,$d0,$68,$68), + ($c3,$82,$41,$41), ($b0,$29,$99,$99), ($77,$5a,$2d,$2d), ($11,$1e,$0f,$0f), + ($cb,$7b,$b0,$b0), ($fc,$a8,$54,$54), ($d6,$6d,$bb,$bb), ($3a,$2c,$16,$16)); + T3: array[0..255,0..3] of byte= ( + ($63,$a5,$c6,$63), ($7c,$84,$f8,$7c), ($77,$99,$ee,$77), ($7b,$8d,$f6,$7b), + ($f2,$0d,$ff,$f2), ($6b,$bd,$d6,$6b), ($6f,$b1,$de,$6f), ($c5,$54,$91,$c5), + ($30,$50,$60,$30), ($01,$03,$02,$01), ($67,$a9,$ce,$67), ($2b,$7d,$56,$2b), + ($fe,$19,$e7,$fe), ($d7,$62,$b5,$d7), ($ab,$e6,$4d,$ab), ($76,$9a,$ec,$76), + ($ca,$45,$8f,$ca), ($82,$9d,$1f,$82), ($c9,$40,$89,$c9), ($7d,$87,$fa,$7d), + ($fa,$15,$ef,$fa), ($59,$eb,$b2,$59), ($47,$c9,$8e,$47), ($f0,$0b,$fb,$f0), + ($ad,$ec,$41,$ad), ($d4,$67,$b3,$d4), ($a2,$fd,$5f,$a2), ($af,$ea,$45,$af), + ($9c,$bf,$23,$9c), ($a4,$f7,$53,$a4), ($72,$96,$e4,$72), ($c0,$5b,$9b,$c0), + ($b7,$c2,$75,$b7), ($fd,$1c,$e1,$fd), ($93,$ae,$3d,$93), ($26,$6a,$4c,$26), + ($36,$5a,$6c,$36), ($3f,$41,$7e,$3f), ($f7,$02,$f5,$f7), ($cc,$4f,$83,$cc), + ($34,$5c,$68,$34), ($a5,$f4,$51,$a5), ($e5,$34,$d1,$e5), ($f1,$08,$f9,$f1), + ($71,$93,$e2,$71), ($d8,$73,$ab,$d8), ($31,$53,$62,$31), ($15,$3f,$2a,$15), + ($04,$0c,$08,$04), ($c7,$52,$95,$c7), ($23,$65,$46,$23), ($c3,$5e,$9d,$c3), + ($18,$28,$30,$18), ($96,$a1,$37,$96), ($05,$0f,$0a,$05), ($9a,$b5,$2f,$9a), + ($07,$09,$0e,$07), ($12,$36,$24,$12), ($80,$9b,$1b,$80), ($e2,$3d,$df,$e2), + ($eb,$26,$cd,$eb), ($27,$69,$4e,$27), ($b2,$cd,$7f,$b2), ($75,$9f,$ea,$75), + ($09,$1b,$12,$09), ($83,$9e,$1d,$83), ($2c,$74,$58,$2c), ($1a,$2e,$34,$1a), + ($1b,$2d,$36,$1b), ($6e,$b2,$dc,$6e), ($5a,$ee,$b4,$5a), ($a0,$fb,$5b,$a0), + ($52,$f6,$a4,$52), ($3b,$4d,$76,$3b), ($d6,$61,$b7,$d6), ($b3,$ce,$7d,$b3), + ($29,$7b,$52,$29), ($e3,$3e,$dd,$e3), ($2f,$71,$5e,$2f), ($84,$97,$13,$84), + ($53,$f5,$a6,$53), ($d1,$68,$b9,$d1), ($00,$00,$00,$00), ($ed,$2c,$c1,$ed), + ($20,$60,$40,$20), ($fc,$1f,$e3,$fc), ($b1,$c8,$79,$b1), ($5b,$ed,$b6,$5b), + ($6a,$be,$d4,$6a), ($cb,$46,$8d,$cb), ($be,$d9,$67,$be), ($39,$4b,$72,$39), + ($4a,$de,$94,$4a), ($4c,$d4,$98,$4c), ($58,$e8,$b0,$58), ($cf,$4a,$85,$cf), + ($d0,$6b,$bb,$d0), ($ef,$2a,$c5,$ef), ($aa,$e5,$4f,$aa), ($fb,$16,$ed,$fb), + ($43,$c5,$86,$43), ($4d,$d7,$9a,$4d), ($33,$55,$66,$33), ($85,$94,$11,$85), + ($45,$cf,$8a,$45), ($f9,$10,$e9,$f9), ($02,$06,$04,$02), ($7f,$81,$fe,$7f), + ($50,$f0,$a0,$50), ($3c,$44,$78,$3c), ($9f,$ba,$25,$9f), ($a8,$e3,$4b,$a8), + ($51,$f3,$a2,$51), ($a3,$fe,$5d,$a3), ($40,$c0,$80,$40), ($8f,$8a,$05,$8f), + ($92,$ad,$3f,$92), ($9d,$bc,$21,$9d), ($38,$48,$70,$38), ($f5,$04,$f1,$f5), + ($bc,$df,$63,$bc), ($b6,$c1,$77,$b6), ($da,$75,$af,$da), ($21,$63,$42,$21), + ($10,$30,$20,$10), ($ff,$1a,$e5,$ff), ($f3,$0e,$fd,$f3), ($d2,$6d,$bf,$d2), + ($cd,$4c,$81,$cd), ($0c,$14,$18,$0c), ($13,$35,$26,$13), ($ec,$2f,$c3,$ec), + ($5f,$e1,$be,$5f), ($97,$a2,$35,$97), ($44,$cc,$88,$44), ($17,$39,$2e,$17), + ($c4,$57,$93,$c4), ($a7,$f2,$55,$a7), ($7e,$82,$fc,$7e), ($3d,$47,$7a,$3d), + ($64,$ac,$c8,$64), ($5d,$e7,$ba,$5d), ($19,$2b,$32,$19), ($73,$95,$e6,$73), + ($60,$a0,$c0,$60), ($81,$98,$19,$81), ($4f,$d1,$9e,$4f), ($dc,$7f,$a3,$dc), + ($22,$66,$44,$22), ($2a,$7e,$54,$2a), ($90,$ab,$3b,$90), ($88,$83,$0b,$88), + ($46,$ca,$8c,$46), ($ee,$29,$c7,$ee), ($b8,$d3,$6b,$b8), ($14,$3c,$28,$14), + ($de,$79,$a7,$de), ($5e,$e2,$bc,$5e), ($0b,$1d,$16,$0b), ($db,$76,$ad,$db), + ($e0,$3b,$db,$e0), ($32,$56,$64,$32), ($3a,$4e,$74,$3a), ($0a,$1e,$14,$0a), + ($49,$db,$92,$49), ($06,$0a,$0c,$06), ($24,$6c,$48,$24), ($5c,$e4,$b8,$5c), + ($c2,$5d,$9f,$c2), ($d3,$6e,$bd,$d3), ($ac,$ef,$43,$ac), ($62,$a6,$c4,$62), + ($91,$a8,$39,$91), ($95,$a4,$31,$95), ($e4,$37,$d3,$e4), ($79,$8b,$f2,$79), + ($e7,$32,$d5,$e7), ($c8,$43,$8b,$c8), ($37,$59,$6e,$37), ($6d,$b7,$da,$6d), + ($8d,$8c,$01,$8d), ($d5,$64,$b1,$d5), ($4e,$d2,$9c,$4e), ($a9,$e0,$49,$a9), + ($6c,$b4,$d8,$6c), ($56,$fa,$ac,$56), ($f4,$07,$f3,$f4), ($ea,$25,$cf,$ea), + ($65,$af,$ca,$65), ($7a,$8e,$f4,$7a), ($ae,$e9,$47,$ae), ($08,$18,$10,$08), + ($ba,$d5,$6f,$ba), ($78,$88,$f0,$78), ($25,$6f,$4a,$25), ($2e,$72,$5c,$2e), + ($1c,$24,$38,$1c), ($a6,$f1,$57,$a6), ($b4,$c7,$73,$b4), ($c6,$51,$97,$c6), + ($e8,$23,$cb,$e8), ($dd,$7c,$a1,$dd), ($74,$9c,$e8,$74), ($1f,$21,$3e,$1f), + ($4b,$dd,$96,$4b), ($bd,$dc,$61,$bd), ($8b,$86,$0d,$8b), ($8a,$85,$0f,$8a), + ($70,$90,$e0,$70), ($3e,$42,$7c,$3e), ($b5,$c4,$71,$b5), ($66,$aa,$cc,$66), + ($48,$d8,$90,$48), ($03,$05,$06,$03), ($f6,$01,$f7,$f6), ($0e,$12,$1c,$0e), + ($61,$a3,$c2,$61), ($35,$5f,$6a,$35), ($57,$f9,$ae,$57), ($b9,$d0,$69,$b9), + ($86,$91,$17,$86), ($c1,$58,$99,$c1), ($1d,$27,$3a,$1d), ($9e,$b9,$27,$9e), + ($e1,$38,$d9,$e1), ($f8,$13,$eb,$f8), ($98,$b3,$2b,$98), ($11,$33,$22,$11), + ($69,$bb,$d2,$69), ($d9,$70,$a9,$d9), ($8e,$89,$07,$8e), ($94,$a7,$33,$94), + ($9b,$b6,$2d,$9b), ($1e,$22,$3c,$1e), ($87,$92,$15,$87), ($e9,$20,$c9,$e9), + ($ce,$49,$87,$ce), ($55,$ff,$aa,$55), ($28,$78,$50,$28), ($df,$7a,$a5,$df), + ($8c,$8f,$03,$8c), ($a1,$f8,$59,$a1), ($89,$80,$09,$89), ($0d,$17,$1a,$0d), + ($bf,$da,$65,$bf), ($e6,$31,$d7,$e6), ($42,$c6,$84,$42), ($68,$b8,$d0,$68), + ($41,$c3,$82,$41), ($99,$b0,$29,$99), ($2d,$77,$5a,$2d), ($0f,$11,$1e,$0f), + ($b0,$cb,$7b,$b0), ($54,$fc,$a8,$54), ($bb,$d6,$6d,$bb), ($16,$3a,$2c,$16)); + T4: array[0..255,0..3] of byte= ( + ($63,$63,$a5,$c6), ($7c,$7c,$84,$f8), ($77,$77,$99,$ee), ($7b,$7b,$8d,$f6), + ($f2,$f2,$0d,$ff), ($6b,$6b,$bd,$d6), ($6f,$6f,$b1,$de), ($c5,$c5,$54,$91), + ($30,$30,$50,$60), ($01,$01,$03,$02), ($67,$67,$a9,$ce), ($2b,$2b,$7d,$56), + ($fe,$fe,$19,$e7), ($d7,$d7,$62,$b5), ($ab,$ab,$e6,$4d), ($76,$76,$9a,$ec), + ($ca,$ca,$45,$8f), ($82,$82,$9d,$1f), ($c9,$c9,$40,$89), ($7d,$7d,$87,$fa), + ($fa,$fa,$15,$ef), ($59,$59,$eb,$b2), ($47,$47,$c9,$8e), ($f0,$f0,$0b,$fb), + ($ad,$ad,$ec,$41), ($d4,$d4,$67,$b3), ($a2,$a2,$fd,$5f), ($af,$af,$ea,$45), + ($9c,$9c,$bf,$23), ($a4,$a4,$f7,$53), ($72,$72,$96,$e4), ($c0,$c0,$5b,$9b), + ($b7,$b7,$c2,$75), ($fd,$fd,$1c,$e1), ($93,$93,$ae,$3d), ($26,$26,$6a,$4c), + ($36,$36,$5a,$6c), ($3f,$3f,$41,$7e), ($f7,$f7,$02,$f5), ($cc,$cc,$4f,$83), + ($34,$34,$5c,$68), ($a5,$a5,$f4,$51), ($e5,$e5,$34,$d1), ($f1,$f1,$08,$f9), + ($71,$71,$93,$e2), ($d8,$d8,$73,$ab), ($31,$31,$53,$62), ($15,$15,$3f,$2a), + ($04,$04,$0c,$08), ($c7,$c7,$52,$95), ($23,$23,$65,$46), ($c3,$c3,$5e,$9d), + ($18,$18,$28,$30), ($96,$96,$a1,$37), ($05,$05,$0f,$0a), ($9a,$9a,$b5,$2f), + ($07,$07,$09,$0e), ($12,$12,$36,$24), ($80,$80,$9b,$1b), ($e2,$e2,$3d,$df), + ($eb,$eb,$26,$cd), ($27,$27,$69,$4e), ($b2,$b2,$cd,$7f), ($75,$75,$9f,$ea), + ($09,$09,$1b,$12), ($83,$83,$9e,$1d), ($2c,$2c,$74,$58), ($1a,$1a,$2e,$34), + ($1b,$1b,$2d,$36), ($6e,$6e,$b2,$dc), ($5a,$5a,$ee,$b4), ($a0,$a0,$fb,$5b), + ($52,$52,$f6,$a4), ($3b,$3b,$4d,$76), ($d6,$d6,$61,$b7), ($b3,$b3,$ce,$7d), + ($29,$29,$7b,$52), ($e3,$e3,$3e,$dd), ($2f,$2f,$71,$5e), ($84,$84,$97,$13), + ($53,$53,$f5,$a6), ($d1,$d1,$68,$b9), ($00,$00,$00,$00), ($ed,$ed,$2c,$c1), + ($20,$20,$60,$40), ($fc,$fc,$1f,$e3), ($b1,$b1,$c8,$79), ($5b,$5b,$ed,$b6), + ($6a,$6a,$be,$d4), ($cb,$cb,$46,$8d), ($be,$be,$d9,$67), ($39,$39,$4b,$72), + ($4a,$4a,$de,$94), ($4c,$4c,$d4,$98), ($58,$58,$e8,$b0), ($cf,$cf,$4a,$85), + ($d0,$d0,$6b,$bb), ($ef,$ef,$2a,$c5), ($aa,$aa,$e5,$4f), ($fb,$fb,$16,$ed), + ($43,$43,$c5,$86), ($4d,$4d,$d7,$9a), ($33,$33,$55,$66), ($85,$85,$94,$11), + ($45,$45,$cf,$8a), ($f9,$f9,$10,$e9), ($02,$02,$06,$04), ($7f,$7f,$81,$fe), + ($50,$50,$f0,$a0), ($3c,$3c,$44,$78), ($9f,$9f,$ba,$25), ($a8,$a8,$e3,$4b), + ($51,$51,$f3,$a2), ($a3,$a3,$fe,$5d), ($40,$40,$c0,$80), ($8f,$8f,$8a,$05), + ($92,$92,$ad,$3f), ($9d,$9d,$bc,$21), ($38,$38,$48,$70), ($f5,$f5,$04,$f1), + ($bc,$bc,$df,$63), ($b6,$b6,$c1,$77), ($da,$da,$75,$af), ($21,$21,$63,$42), + ($10,$10,$30,$20), ($ff,$ff,$1a,$e5), ($f3,$f3,$0e,$fd), ($d2,$d2,$6d,$bf), + ($cd,$cd,$4c,$81), ($0c,$0c,$14,$18), ($13,$13,$35,$26), ($ec,$ec,$2f,$c3), + ($5f,$5f,$e1,$be), ($97,$97,$a2,$35), ($44,$44,$cc,$88), ($17,$17,$39,$2e), + ($c4,$c4,$57,$93), ($a7,$a7,$f2,$55), ($7e,$7e,$82,$fc), ($3d,$3d,$47,$7a), + ($64,$64,$ac,$c8), ($5d,$5d,$e7,$ba), ($19,$19,$2b,$32), ($73,$73,$95,$e6), + ($60,$60,$a0,$c0), ($81,$81,$98,$19), ($4f,$4f,$d1,$9e), ($dc,$dc,$7f,$a3), + ($22,$22,$66,$44), ($2a,$2a,$7e,$54), ($90,$90,$ab,$3b), ($88,$88,$83,$0b), + ($46,$46,$ca,$8c), ($ee,$ee,$29,$c7), ($b8,$b8,$d3,$6b), ($14,$14,$3c,$28), + ($de,$de,$79,$a7), ($5e,$5e,$e2,$bc), ($0b,$0b,$1d,$16), ($db,$db,$76,$ad), + ($e0,$e0,$3b,$db), ($32,$32,$56,$64), ($3a,$3a,$4e,$74), ($0a,$0a,$1e,$14), + ($49,$49,$db,$92), ($06,$06,$0a,$0c), ($24,$24,$6c,$48), ($5c,$5c,$e4,$b8), + ($c2,$c2,$5d,$9f), ($d3,$d3,$6e,$bd), ($ac,$ac,$ef,$43), ($62,$62,$a6,$c4), + ($91,$91,$a8,$39), ($95,$95,$a4,$31), ($e4,$e4,$37,$d3), ($79,$79,$8b,$f2), + ($e7,$e7,$32,$d5), ($c8,$c8,$43,$8b), ($37,$37,$59,$6e), ($6d,$6d,$b7,$da), + ($8d,$8d,$8c,$01), ($d5,$d5,$64,$b1), ($4e,$4e,$d2,$9c), ($a9,$a9,$e0,$49), + ($6c,$6c,$b4,$d8), ($56,$56,$fa,$ac), ($f4,$f4,$07,$f3), ($ea,$ea,$25,$cf), + ($65,$65,$af,$ca), ($7a,$7a,$8e,$f4), ($ae,$ae,$e9,$47), ($08,$08,$18,$10), + ($ba,$ba,$d5,$6f), ($78,$78,$88,$f0), ($25,$25,$6f,$4a), ($2e,$2e,$72,$5c), + ($1c,$1c,$24,$38), ($a6,$a6,$f1,$57), ($b4,$b4,$c7,$73), ($c6,$c6,$51,$97), + ($e8,$e8,$23,$cb), ($dd,$dd,$7c,$a1), ($74,$74,$9c,$e8), ($1f,$1f,$21,$3e), + ($4b,$4b,$dd,$96), ($bd,$bd,$dc,$61), ($8b,$8b,$86,$0d), ($8a,$8a,$85,$0f), + ($70,$70,$90,$e0), ($3e,$3e,$42,$7c), ($b5,$b5,$c4,$71), ($66,$66,$aa,$cc), + ($48,$48,$d8,$90), ($03,$03,$05,$06), ($f6,$f6,$01,$f7), ($0e,$0e,$12,$1c), + ($61,$61,$a3,$c2), ($35,$35,$5f,$6a), ($57,$57,$f9,$ae), ($b9,$b9,$d0,$69), + ($86,$86,$91,$17), ($c1,$c1,$58,$99), ($1d,$1d,$27,$3a), ($9e,$9e,$b9,$27), + ($e1,$e1,$38,$d9), ($f8,$f8,$13,$eb), ($98,$98,$b3,$2b), ($11,$11,$33,$22), + ($69,$69,$bb,$d2), ($d9,$d9,$70,$a9), ($8e,$8e,$89,$07), ($94,$94,$a7,$33), + ($9b,$9b,$b6,$2d), ($1e,$1e,$22,$3c), ($87,$87,$92,$15), ($e9,$e9,$20,$c9), + ($ce,$ce,$49,$87), ($55,$55,$ff,$aa), ($28,$28,$78,$50), ($df,$df,$7a,$a5), + ($8c,$8c,$8f,$03), ($a1,$a1,$f8,$59), ($89,$89,$80,$09), ($0d,$0d,$17,$1a), + ($bf,$bf,$da,$65), ($e6,$e6,$31,$d7), ($42,$42,$c6,$84), ($68,$68,$b8,$d0), + ($41,$41,$c3,$82), ($99,$99,$b0,$29), ($2d,$2d,$77,$5a), ($0f,$0f,$11,$1e), + ($b0,$b0,$cb,$7b), ($54,$54,$fc,$a8), ($bb,$bb,$d6,$6d), ($16,$16,$3a,$2c)); + T5: array[0..255,0..3] of byte= ( + ($51,$f4,$a7,$50), ($7e,$41,$65,$53), ($1a,$17,$a4,$c3), ($3a,$27,$5e,$96), + ($3b,$ab,$6b,$cb), ($1f,$9d,$45,$f1), ($ac,$fa,$58,$ab), ($4b,$e3,$03,$93), + ($20,$30,$fa,$55), ($ad,$76,$6d,$f6), ($88,$cc,$76,$91), ($f5,$02,$4c,$25), + ($4f,$e5,$d7,$fc), ($c5,$2a,$cb,$d7), ($26,$35,$44,$80), ($b5,$62,$a3,$8f), + ($de,$b1,$5a,$49), ($25,$ba,$1b,$67), ($45,$ea,$0e,$98), ($5d,$fe,$c0,$e1), + ($c3,$2f,$75,$02), ($81,$4c,$f0,$12), ($8d,$46,$97,$a3), ($6b,$d3,$f9,$c6), + ($03,$8f,$5f,$e7), ($15,$92,$9c,$95), ($bf,$6d,$7a,$eb), ($95,$52,$59,$da), + ($d4,$be,$83,$2d), ($58,$74,$21,$d3), ($49,$e0,$69,$29), ($8e,$c9,$c8,$44), + ($75,$c2,$89,$6a), ($f4,$8e,$79,$78), ($99,$58,$3e,$6b), ($27,$b9,$71,$dd), + ($be,$e1,$4f,$b6), ($f0,$88,$ad,$17), ($c9,$20,$ac,$66), ($7d,$ce,$3a,$b4), + ($63,$df,$4a,$18), ($e5,$1a,$31,$82), ($97,$51,$33,$60), ($62,$53,$7f,$45), + ($b1,$64,$77,$e0), ($bb,$6b,$ae,$84), ($fe,$81,$a0,$1c), ($f9,$08,$2b,$94), + ($70,$48,$68,$58), ($8f,$45,$fd,$19), ($94,$de,$6c,$87), ($52,$7b,$f8,$b7), + ($ab,$73,$d3,$23), ($72,$4b,$02,$e2), ($e3,$1f,$8f,$57), ($66,$55,$ab,$2a), + ($b2,$eb,$28,$07), ($2f,$b5,$c2,$03), ($86,$c5,$7b,$9a), ($d3,$37,$08,$a5), + ($30,$28,$87,$f2), ($23,$bf,$a5,$b2), ($02,$03,$6a,$ba), ($ed,$16,$82,$5c), + ($8a,$cf,$1c,$2b), ($a7,$79,$b4,$92), ($f3,$07,$f2,$f0), ($4e,$69,$e2,$a1), + ($65,$da,$f4,$cd), ($06,$05,$be,$d5), ($d1,$34,$62,$1f), ($c4,$a6,$fe,$8a), + ($34,$2e,$53,$9d), ($a2,$f3,$55,$a0), ($05,$8a,$e1,$32), ($a4,$f6,$eb,$75), + ($0b,$83,$ec,$39), ($40,$60,$ef,$aa), ($5e,$71,$9f,$06), ($bd,$6e,$10,$51), + ($3e,$21,$8a,$f9), ($96,$dd,$06,$3d), ($dd,$3e,$05,$ae), ($4d,$e6,$bd,$46), + ($91,$54,$8d,$b5), ($71,$c4,$5d,$05), ($04,$06,$d4,$6f), ($60,$50,$15,$ff), + ($19,$98,$fb,$24), ($d6,$bd,$e9,$97), ($89,$40,$43,$cc), ($67,$d9,$9e,$77), + ($b0,$e8,$42,$bd), ($07,$89,$8b,$88), ($e7,$19,$5b,$38), ($79,$c8,$ee,$db), + ($a1,$7c,$0a,$47), ($7c,$42,$0f,$e9), ($f8,$84,$1e,$c9), ($00,$00,$00,$00), + ($09,$80,$86,$83), ($32,$2b,$ed,$48), ($1e,$11,$70,$ac), ($6c,$5a,$72,$4e), + ($fd,$0e,$ff,$fb), ($0f,$85,$38,$56), ($3d,$ae,$d5,$1e), ($36,$2d,$39,$27), + ($0a,$0f,$d9,$64), ($68,$5c,$a6,$21), ($9b,$5b,$54,$d1), ($24,$36,$2e,$3a), + ($0c,$0a,$67,$b1), ($93,$57,$e7,$0f), ($b4,$ee,$96,$d2), ($1b,$9b,$91,$9e), + ($80,$c0,$c5,$4f), ($61,$dc,$20,$a2), ($5a,$77,$4b,$69), ($1c,$12,$1a,$16), + ($e2,$93,$ba,$0a), ($c0,$a0,$2a,$e5), ($3c,$22,$e0,$43), ($12,$1b,$17,$1d), + ($0e,$09,$0d,$0b), ($f2,$8b,$c7,$ad), ($2d,$b6,$a8,$b9), ($14,$1e,$a9,$c8), + ($57,$f1,$19,$85), ($af,$75,$07,$4c), ($ee,$99,$dd,$bb), ($a3,$7f,$60,$fd), + ($f7,$01,$26,$9f), ($5c,$72,$f5,$bc), ($44,$66,$3b,$c5), ($5b,$fb,$7e,$34), + ($8b,$43,$29,$76), ($cb,$23,$c6,$dc), ($b6,$ed,$fc,$68), ($b8,$e4,$f1,$63), + ($d7,$31,$dc,$ca), ($42,$63,$85,$10), ($13,$97,$22,$40), ($84,$c6,$11,$20), + ($85,$4a,$24,$7d), ($d2,$bb,$3d,$f8), ($ae,$f9,$32,$11), ($c7,$29,$a1,$6d), + ($1d,$9e,$2f,$4b), ($dc,$b2,$30,$f3), ($0d,$86,$52,$ec), ($77,$c1,$e3,$d0), + ($2b,$b3,$16,$6c), ($a9,$70,$b9,$99), ($11,$94,$48,$fa), ($47,$e9,$64,$22), + ($a8,$fc,$8c,$c4), ($a0,$f0,$3f,$1a), ($56,$7d,$2c,$d8), ($22,$33,$90,$ef), + ($87,$49,$4e,$c7), ($d9,$38,$d1,$c1), ($8c,$ca,$a2,$fe), ($98,$d4,$0b,$36), + ($a6,$f5,$81,$cf), ($a5,$7a,$de,$28), ($da,$b7,$8e,$26), ($3f,$ad,$bf,$a4), + ($2c,$3a,$9d,$e4), ($50,$78,$92,$0d), ($6a,$5f,$cc,$9b), ($54,$7e,$46,$62), + ($f6,$8d,$13,$c2), ($90,$d8,$b8,$e8), ($2e,$39,$f7,$5e), ($82,$c3,$af,$f5), + ($9f,$5d,$80,$be), ($69,$d0,$93,$7c), ($6f,$d5,$2d,$a9), ($cf,$25,$12,$b3), + ($c8,$ac,$99,$3b), ($10,$18,$7d,$a7), ($e8,$9c,$63,$6e), ($db,$3b,$bb,$7b), + ($cd,$26,$78,$09), ($6e,$59,$18,$f4), ($ec,$9a,$b7,$01), ($83,$4f,$9a,$a8), + ($e6,$95,$6e,$65), ($aa,$ff,$e6,$7e), ($21,$bc,$cf,$08), ($ef,$15,$e8,$e6), + ($ba,$e7,$9b,$d9), ($4a,$6f,$36,$ce), ($ea,$9f,$09,$d4), ($29,$b0,$7c,$d6), + ($31,$a4,$b2,$af), ($2a,$3f,$23,$31), ($c6,$a5,$94,$30), ($35,$a2,$66,$c0), + ($74,$4e,$bc,$37), ($fc,$82,$ca,$a6), ($e0,$90,$d0,$b0), ($33,$a7,$d8,$15), + ($f1,$04,$98,$4a), ($41,$ec,$da,$f7), ($7f,$cd,$50,$0e), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($43,$ef,$b0,$4d), ($cc,$aa,$4d,$54), ($e4,$96,$04,$df), + ($9e,$d1,$b5,$e3), ($4c,$6a,$88,$1b), ($c1,$2c,$1f,$b8), ($46,$65,$51,$7f), + ($9d,$5e,$ea,$04), ($01,$8c,$35,$5d), ($fa,$87,$74,$73), ($fb,$0b,$41,$2e), + ($b3,$67,$1d,$5a), ($92,$db,$d2,$52), ($e9,$10,$56,$33), ($6d,$d6,$47,$13), + ($9a,$d7,$61,$8c), ($37,$a1,$0c,$7a), ($59,$f8,$14,$8e), ($eb,$13,$3c,$89), + ($ce,$a9,$27,$ee), ($b7,$61,$c9,$35), ($e1,$1c,$e5,$ed), ($7a,$47,$b1,$3c), + ($9c,$d2,$df,$59), ($55,$f2,$73,$3f), ($18,$14,$ce,$79), ($73,$c7,$37,$bf), + ($53,$f7,$cd,$ea), ($5f,$fd,$aa,$5b), ($df,$3d,$6f,$14), ($78,$44,$db,$86), + ($ca,$af,$f3,$81), ($b9,$68,$c4,$3e), ($38,$24,$34,$2c), ($c2,$a3,$40,$5f), + ($16,$1d,$c3,$72), ($bc,$e2,$25,$0c), ($28,$3c,$49,$8b), ($ff,$0d,$95,$41), + ($39,$a8,$01,$71), ($08,$0c,$b3,$de), ($d8,$b4,$e4,$9c), ($64,$56,$c1,$90), + ($7b,$cb,$84,$61), ($d5,$32,$b6,$70), ($48,$6c,$5c,$74), ($d0,$b8,$57,$42)); + T6: array[0..255,0..3] of byte= ( + ($50,$51,$f4,$a7), ($53,$7e,$41,$65), ($c3,$1a,$17,$a4), ($96,$3a,$27,$5e), + ($cb,$3b,$ab,$6b), ($f1,$1f,$9d,$45), ($ab,$ac,$fa,$58), ($93,$4b,$e3,$03), + ($55,$20,$30,$fa), ($f6,$ad,$76,$6d), ($91,$88,$cc,$76), ($25,$f5,$02,$4c), + ($fc,$4f,$e5,$d7), ($d7,$c5,$2a,$cb), ($80,$26,$35,$44), ($8f,$b5,$62,$a3), + ($49,$de,$b1,$5a), ($67,$25,$ba,$1b), ($98,$45,$ea,$0e), ($e1,$5d,$fe,$c0), + ($02,$c3,$2f,$75), ($12,$81,$4c,$f0), ($a3,$8d,$46,$97), ($c6,$6b,$d3,$f9), + ($e7,$03,$8f,$5f), ($95,$15,$92,$9c), ($eb,$bf,$6d,$7a), ($da,$95,$52,$59), + ($2d,$d4,$be,$83), ($d3,$58,$74,$21), ($29,$49,$e0,$69), ($44,$8e,$c9,$c8), + ($6a,$75,$c2,$89), ($78,$f4,$8e,$79), ($6b,$99,$58,$3e), ($dd,$27,$b9,$71), + ($b6,$be,$e1,$4f), ($17,$f0,$88,$ad), ($66,$c9,$20,$ac), ($b4,$7d,$ce,$3a), + ($18,$63,$df,$4a), ($82,$e5,$1a,$31), ($60,$97,$51,$33), ($45,$62,$53,$7f), + ($e0,$b1,$64,$77), ($84,$bb,$6b,$ae), ($1c,$fe,$81,$a0), ($94,$f9,$08,$2b), + ($58,$70,$48,$68), ($19,$8f,$45,$fd), ($87,$94,$de,$6c), ($b7,$52,$7b,$f8), + ($23,$ab,$73,$d3), ($e2,$72,$4b,$02), ($57,$e3,$1f,$8f), ($2a,$66,$55,$ab), + ($07,$b2,$eb,$28), ($03,$2f,$b5,$c2), ($9a,$86,$c5,$7b), ($a5,$d3,$37,$08), + ($f2,$30,$28,$87), ($b2,$23,$bf,$a5), ($ba,$02,$03,$6a), ($5c,$ed,$16,$82), + ($2b,$8a,$cf,$1c), ($92,$a7,$79,$b4), ($f0,$f3,$07,$f2), ($a1,$4e,$69,$e2), + ($cd,$65,$da,$f4), ($d5,$06,$05,$be), ($1f,$d1,$34,$62), ($8a,$c4,$a6,$fe), + ($9d,$34,$2e,$53), ($a0,$a2,$f3,$55), ($32,$05,$8a,$e1), ($75,$a4,$f6,$eb), + ($39,$0b,$83,$ec), ($aa,$40,$60,$ef), ($06,$5e,$71,$9f), ($51,$bd,$6e,$10), + ($f9,$3e,$21,$8a), ($3d,$96,$dd,$06), ($ae,$dd,$3e,$05), ($46,$4d,$e6,$bd), + ($b5,$91,$54,$8d), ($05,$71,$c4,$5d), ($6f,$04,$06,$d4), ($ff,$60,$50,$15), + ($24,$19,$98,$fb), ($97,$d6,$bd,$e9), ($cc,$89,$40,$43), ($77,$67,$d9,$9e), + ($bd,$b0,$e8,$42), ($88,$07,$89,$8b), ($38,$e7,$19,$5b), ($db,$79,$c8,$ee), + ($47,$a1,$7c,$0a), ($e9,$7c,$42,$0f), ($c9,$f8,$84,$1e), ($00,$00,$00,$00), + ($83,$09,$80,$86), ($48,$32,$2b,$ed), ($ac,$1e,$11,$70), ($4e,$6c,$5a,$72), + ($fb,$fd,$0e,$ff), ($56,$0f,$85,$38), ($1e,$3d,$ae,$d5), ($27,$36,$2d,$39), + ($64,$0a,$0f,$d9), ($21,$68,$5c,$a6), ($d1,$9b,$5b,$54), ($3a,$24,$36,$2e), + ($b1,$0c,$0a,$67), ($0f,$93,$57,$e7), ($d2,$b4,$ee,$96), ($9e,$1b,$9b,$91), + ($4f,$80,$c0,$c5), ($a2,$61,$dc,$20), ($69,$5a,$77,$4b), ($16,$1c,$12,$1a), + ($0a,$e2,$93,$ba), ($e5,$c0,$a0,$2a), ($43,$3c,$22,$e0), ($1d,$12,$1b,$17), + ($0b,$0e,$09,$0d), ($ad,$f2,$8b,$c7), ($b9,$2d,$b6,$a8), ($c8,$14,$1e,$a9), + ($85,$57,$f1,$19), ($4c,$af,$75,$07), ($bb,$ee,$99,$dd), ($fd,$a3,$7f,$60), + ($9f,$f7,$01,$26), ($bc,$5c,$72,$f5), ($c5,$44,$66,$3b), ($34,$5b,$fb,$7e), + ($76,$8b,$43,$29), ($dc,$cb,$23,$c6), ($68,$b6,$ed,$fc), ($63,$b8,$e4,$f1), + ($ca,$d7,$31,$dc), ($10,$42,$63,$85), ($40,$13,$97,$22), ($20,$84,$c6,$11), + ($7d,$85,$4a,$24), ($f8,$d2,$bb,$3d), ($11,$ae,$f9,$32), ($6d,$c7,$29,$a1), + ($4b,$1d,$9e,$2f), ($f3,$dc,$b2,$30), ($ec,$0d,$86,$52), ($d0,$77,$c1,$e3), + ($6c,$2b,$b3,$16), ($99,$a9,$70,$b9), ($fa,$11,$94,$48), ($22,$47,$e9,$64), + ($c4,$a8,$fc,$8c), ($1a,$a0,$f0,$3f), ($d8,$56,$7d,$2c), ($ef,$22,$33,$90), + ($c7,$87,$49,$4e), ($c1,$d9,$38,$d1), ($fe,$8c,$ca,$a2), ($36,$98,$d4,$0b), + ($cf,$a6,$f5,$81), ($28,$a5,$7a,$de), ($26,$da,$b7,$8e), ($a4,$3f,$ad,$bf), + ($e4,$2c,$3a,$9d), ($0d,$50,$78,$92), ($9b,$6a,$5f,$cc), ($62,$54,$7e,$46), + ($c2,$f6,$8d,$13), ($e8,$90,$d8,$b8), ($5e,$2e,$39,$f7), ($f5,$82,$c3,$af), + ($be,$9f,$5d,$80), ($7c,$69,$d0,$93), ($a9,$6f,$d5,$2d), ($b3,$cf,$25,$12), + ($3b,$c8,$ac,$99), ($a7,$10,$18,$7d), ($6e,$e8,$9c,$63), ($7b,$db,$3b,$bb), + ($09,$cd,$26,$78), ($f4,$6e,$59,$18), ($01,$ec,$9a,$b7), ($a8,$83,$4f,$9a), + ($65,$e6,$95,$6e), ($7e,$aa,$ff,$e6), ($08,$21,$bc,$cf), ($e6,$ef,$15,$e8), + ($d9,$ba,$e7,$9b), ($ce,$4a,$6f,$36), ($d4,$ea,$9f,$09), ($d6,$29,$b0,$7c), + ($af,$31,$a4,$b2), ($31,$2a,$3f,$23), ($30,$c6,$a5,$94), ($c0,$35,$a2,$66), + ($37,$74,$4e,$bc), ($a6,$fc,$82,$ca), ($b0,$e0,$90,$d0), ($15,$33,$a7,$d8), + ($4a,$f1,$04,$98), ($f7,$41,$ec,$da), ($0e,$7f,$cd,$50), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($4d,$43,$ef,$b0), ($54,$cc,$aa,$4d), ($df,$e4,$96,$04), + ($e3,$9e,$d1,$b5), ($1b,$4c,$6a,$88), ($b8,$c1,$2c,$1f), ($7f,$46,$65,$51), + ($04,$9d,$5e,$ea), ($5d,$01,$8c,$35), ($73,$fa,$87,$74), ($2e,$fb,$0b,$41), + ($5a,$b3,$67,$1d), ($52,$92,$db,$d2), ($33,$e9,$10,$56), ($13,$6d,$d6,$47), + ($8c,$9a,$d7,$61), ($7a,$37,$a1,$0c), ($8e,$59,$f8,$14), ($89,$eb,$13,$3c), + ($ee,$ce,$a9,$27), ($35,$b7,$61,$c9), ($ed,$e1,$1c,$e5), ($3c,$7a,$47,$b1), + ($59,$9c,$d2,$df), ($3f,$55,$f2,$73), ($79,$18,$14,$ce), ($bf,$73,$c7,$37), + ($ea,$53,$f7,$cd), ($5b,$5f,$fd,$aa), ($14,$df,$3d,$6f), ($86,$78,$44,$db), + ($81,$ca,$af,$f3), ($3e,$b9,$68,$c4), ($2c,$38,$24,$34), ($5f,$c2,$a3,$40), + ($72,$16,$1d,$c3), ($0c,$bc,$e2,$25), ($8b,$28,$3c,$49), ($41,$ff,$0d,$95), + ($71,$39,$a8,$01), ($de,$08,$0c,$b3), ($9c,$d8,$b4,$e4), ($90,$64,$56,$c1), + ($61,$7b,$cb,$84), ($70,$d5,$32,$b6), ($74,$48,$6c,$5c), ($42,$d0,$b8,$57)); + T7: array[0..255,0..3] of byte= ( + ($a7,$50,$51,$f4), ($65,$53,$7e,$41), ($a4,$c3,$1a,$17), ($5e,$96,$3a,$27), + ($6b,$cb,$3b,$ab), ($45,$f1,$1f,$9d), ($58,$ab,$ac,$fa), ($03,$93,$4b,$e3), + ($fa,$55,$20,$30), ($6d,$f6,$ad,$76), ($76,$91,$88,$cc), ($4c,$25,$f5,$02), + ($d7,$fc,$4f,$e5), ($cb,$d7,$c5,$2a), ($44,$80,$26,$35), ($a3,$8f,$b5,$62), + ($5a,$49,$de,$b1), ($1b,$67,$25,$ba), ($0e,$98,$45,$ea), ($c0,$e1,$5d,$fe), + ($75,$02,$c3,$2f), ($f0,$12,$81,$4c), ($97,$a3,$8d,$46), ($f9,$c6,$6b,$d3), + ($5f,$e7,$03,$8f), ($9c,$95,$15,$92), ($7a,$eb,$bf,$6d), ($59,$da,$95,$52), + ($83,$2d,$d4,$be), ($21,$d3,$58,$74), ($69,$29,$49,$e0), ($c8,$44,$8e,$c9), + ($89,$6a,$75,$c2), ($79,$78,$f4,$8e), ($3e,$6b,$99,$58), ($71,$dd,$27,$b9), + ($4f,$b6,$be,$e1), ($ad,$17,$f0,$88), ($ac,$66,$c9,$20), ($3a,$b4,$7d,$ce), + ($4a,$18,$63,$df), ($31,$82,$e5,$1a), ($33,$60,$97,$51), ($7f,$45,$62,$53), + ($77,$e0,$b1,$64), ($ae,$84,$bb,$6b), ($a0,$1c,$fe,$81), ($2b,$94,$f9,$08), + ($68,$58,$70,$48), ($fd,$19,$8f,$45), ($6c,$87,$94,$de), ($f8,$b7,$52,$7b), + ($d3,$23,$ab,$73), ($02,$e2,$72,$4b), ($8f,$57,$e3,$1f), ($ab,$2a,$66,$55), + ($28,$07,$b2,$eb), ($c2,$03,$2f,$b5), ($7b,$9a,$86,$c5), ($08,$a5,$d3,$37), + ($87,$f2,$30,$28), ($a5,$b2,$23,$bf), ($6a,$ba,$02,$03), ($82,$5c,$ed,$16), + ($1c,$2b,$8a,$cf), ($b4,$92,$a7,$79), ($f2,$f0,$f3,$07), ($e2,$a1,$4e,$69), + ($f4,$cd,$65,$da), ($be,$d5,$06,$05), ($62,$1f,$d1,$34), ($fe,$8a,$c4,$a6), + ($53,$9d,$34,$2e), ($55,$a0,$a2,$f3), ($e1,$32,$05,$8a), ($eb,$75,$a4,$f6), + ($ec,$39,$0b,$83), ($ef,$aa,$40,$60), ($9f,$06,$5e,$71), ($10,$51,$bd,$6e), + ($8a,$f9,$3e,$21), ($06,$3d,$96,$dd), ($05,$ae,$dd,$3e), ($bd,$46,$4d,$e6), + ($8d,$b5,$91,$54), ($5d,$05,$71,$c4), ($d4,$6f,$04,$06), ($15,$ff,$60,$50), + ($fb,$24,$19,$98), ($e9,$97,$d6,$bd), ($43,$cc,$89,$40), ($9e,$77,$67,$d9), + ($42,$bd,$b0,$e8), ($8b,$88,$07,$89), ($5b,$38,$e7,$19), ($ee,$db,$79,$c8), + ($0a,$47,$a1,$7c), ($0f,$e9,$7c,$42), ($1e,$c9,$f8,$84), ($00,$00,$00,$00), + ($86,$83,$09,$80), ($ed,$48,$32,$2b), ($70,$ac,$1e,$11), ($72,$4e,$6c,$5a), + ($ff,$fb,$fd,$0e), ($38,$56,$0f,$85), ($d5,$1e,$3d,$ae), ($39,$27,$36,$2d), + ($d9,$64,$0a,$0f), ($a6,$21,$68,$5c), ($54,$d1,$9b,$5b), ($2e,$3a,$24,$36), + ($67,$b1,$0c,$0a), ($e7,$0f,$93,$57), ($96,$d2,$b4,$ee), ($91,$9e,$1b,$9b), + ($c5,$4f,$80,$c0), ($20,$a2,$61,$dc), ($4b,$69,$5a,$77), ($1a,$16,$1c,$12), + ($ba,$0a,$e2,$93), ($2a,$e5,$c0,$a0), ($e0,$43,$3c,$22), ($17,$1d,$12,$1b), + ($0d,$0b,$0e,$09), ($c7,$ad,$f2,$8b), ($a8,$b9,$2d,$b6), ($a9,$c8,$14,$1e), + ($19,$85,$57,$f1), ($07,$4c,$af,$75), ($dd,$bb,$ee,$99), ($60,$fd,$a3,$7f), + ($26,$9f,$f7,$01), ($f5,$bc,$5c,$72), ($3b,$c5,$44,$66), ($7e,$34,$5b,$fb), + ($29,$76,$8b,$43), ($c6,$dc,$cb,$23), ($fc,$68,$b6,$ed), ($f1,$63,$b8,$e4), + ($dc,$ca,$d7,$31), ($85,$10,$42,$63), ($22,$40,$13,$97), ($11,$20,$84,$c6), + ($24,$7d,$85,$4a), ($3d,$f8,$d2,$bb), ($32,$11,$ae,$f9), ($a1,$6d,$c7,$29), + ($2f,$4b,$1d,$9e), ($30,$f3,$dc,$b2), ($52,$ec,$0d,$86), ($e3,$d0,$77,$c1), + ($16,$6c,$2b,$b3), ($b9,$99,$a9,$70), ($48,$fa,$11,$94), ($64,$22,$47,$e9), + ($8c,$c4,$a8,$fc), ($3f,$1a,$a0,$f0), ($2c,$d8,$56,$7d), ($90,$ef,$22,$33), + ($4e,$c7,$87,$49), ($d1,$c1,$d9,$38), ($a2,$fe,$8c,$ca), ($0b,$36,$98,$d4), + ($81,$cf,$a6,$f5), ($de,$28,$a5,$7a), ($8e,$26,$da,$b7), ($bf,$a4,$3f,$ad), + ($9d,$e4,$2c,$3a), ($92,$0d,$50,$78), ($cc,$9b,$6a,$5f), ($46,$62,$54,$7e), + ($13,$c2,$f6,$8d), ($b8,$e8,$90,$d8), ($f7,$5e,$2e,$39), ($af,$f5,$82,$c3), + ($80,$be,$9f,$5d), ($93,$7c,$69,$d0), ($2d,$a9,$6f,$d5), ($12,$b3,$cf,$25), + ($99,$3b,$c8,$ac), ($7d,$a7,$10,$18), ($63,$6e,$e8,$9c), ($bb,$7b,$db,$3b), + ($78,$09,$cd,$26), ($18,$f4,$6e,$59), ($b7,$01,$ec,$9a), ($9a,$a8,$83,$4f), + ($6e,$65,$e6,$95), ($e6,$7e,$aa,$ff), ($cf,$08,$21,$bc), ($e8,$e6,$ef,$15), + ($9b,$d9,$ba,$e7), ($36,$ce,$4a,$6f), ($09,$d4,$ea,$9f), ($7c,$d6,$29,$b0), + ($b2,$af,$31,$a4), ($23,$31,$2a,$3f), ($94,$30,$c6,$a5), ($66,$c0,$35,$a2), + ($bc,$37,$74,$4e), ($ca,$a6,$fc,$82), ($d0,$b0,$e0,$90), ($d8,$15,$33,$a7), + ($98,$4a,$f1,$04), ($da,$f7,$41,$ec), ($50,$0e,$7f,$cd), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($b0,$4d,$43,$ef), ($4d,$54,$cc,$aa), ($04,$df,$e4,$96), + ($b5,$e3,$9e,$d1), ($88,$1b,$4c,$6a), ($1f,$b8,$c1,$2c), ($51,$7f,$46,$65), + ($ea,$04,$9d,$5e), ($35,$5d,$01,$8c), ($74,$73,$fa,$87), ($41,$2e,$fb,$0b), + ($1d,$5a,$b3,$67), ($d2,$52,$92,$db), ($56,$33,$e9,$10), ($47,$13,$6d,$d6), + ($61,$8c,$9a,$d7), ($0c,$7a,$37,$a1), ($14,$8e,$59,$f8), ($3c,$89,$eb,$13), + ($27,$ee,$ce,$a9), ($c9,$35,$b7,$61), ($e5,$ed,$e1,$1c), ($b1,$3c,$7a,$47), + ($df,$59,$9c,$d2), ($73,$3f,$55,$f2), ($ce,$79,$18,$14), ($37,$bf,$73,$c7), + ($cd,$ea,$53,$f7), ($aa,$5b,$5f,$fd), ($6f,$14,$df,$3d), ($db,$86,$78,$44), + ($f3,$81,$ca,$af), ($c4,$3e,$b9,$68), ($34,$2c,$38,$24), ($40,$5f,$c2,$a3), + ($c3,$72,$16,$1d), ($25,$0c,$bc,$e2), ($49,$8b,$28,$3c), ($95,$41,$ff,$0d), + ($01,$71,$39,$a8), ($b3,$de,$08,$0c), ($e4,$9c,$d8,$b4), ($c1,$90,$64,$56), + ($84,$61,$7b,$cb), ($b6,$70,$d5,$32), ($5c,$74,$48,$6c), ($57,$42,$d0,$b8)); + T8: array[0..255,0..3] of byte= ( + ($f4,$a7,$50,$51), ($41,$65,$53,$7e), ($17,$a4,$c3,$1a), ($27,$5e,$96,$3a), + ($ab,$6b,$cb,$3b), ($9d,$45,$f1,$1f), ($fa,$58,$ab,$ac), ($e3,$03,$93,$4b), + ($30,$fa,$55,$20), ($76,$6d,$f6,$ad), ($cc,$76,$91,$88), ($02,$4c,$25,$f5), + ($e5,$d7,$fc,$4f), ($2a,$cb,$d7,$c5), ($35,$44,$80,$26), ($62,$a3,$8f,$b5), + ($b1,$5a,$49,$de), ($ba,$1b,$67,$25), ($ea,$0e,$98,$45), ($fe,$c0,$e1,$5d), + ($2f,$75,$02,$c3), ($4c,$f0,$12,$81), ($46,$97,$a3,$8d), ($d3,$f9,$c6,$6b), + ($8f,$5f,$e7,$03), ($92,$9c,$95,$15), ($6d,$7a,$eb,$bf), ($52,$59,$da,$95), + ($be,$83,$2d,$d4), ($74,$21,$d3,$58), ($e0,$69,$29,$49), ($c9,$c8,$44,$8e), + ($c2,$89,$6a,$75), ($8e,$79,$78,$f4), ($58,$3e,$6b,$99), ($b9,$71,$dd,$27), + ($e1,$4f,$b6,$be), ($88,$ad,$17,$f0), ($20,$ac,$66,$c9), ($ce,$3a,$b4,$7d), + ($df,$4a,$18,$63), ($1a,$31,$82,$e5), ($51,$33,$60,$97), ($53,$7f,$45,$62), + ($64,$77,$e0,$b1), ($6b,$ae,$84,$bb), ($81,$a0,$1c,$fe), ($08,$2b,$94,$f9), + ($48,$68,$58,$70), ($45,$fd,$19,$8f), ($de,$6c,$87,$94), ($7b,$f8,$b7,$52), + ($73,$d3,$23,$ab), ($4b,$02,$e2,$72), ($1f,$8f,$57,$e3), ($55,$ab,$2a,$66), + ($eb,$28,$07,$b2), ($b5,$c2,$03,$2f), ($c5,$7b,$9a,$86), ($37,$08,$a5,$d3), + ($28,$87,$f2,$30), ($bf,$a5,$b2,$23), ($03,$6a,$ba,$02), ($16,$82,$5c,$ed), + ($cf,$1c,$2b,$8a), ($79,$b4,$92,$a7), ($07,$f2,$f0,$f3), ($69,$e2,$a1,$4e), + ($da,$f4,$cd,$65), ($05,$be,$d5,$06), ($34,$62,$1f,$d1), ($a6,$fe,$8a,$c4), + ($2e,$53,$9d,$34), ($f3,$55,$a0,$a2), ($8a,$e1,$32,$05), ($f6,$eb,$75,$a4), + ($83,$ec,$39,$0b), ($60,$ef,$aa,$40), ($71,$9f,$06,$5e), ($6e,$10,$51,$bd), + ($21,$8a,$f9,$3e), ($dd,$06,$3d,$96), ($3e,$05,$ae,$dd), ($e6,$bd,$46,$4d), + ($54,$8d,$b5,$91), ($c4,$5d,$05,$71), ($06,$d4,$6f,$04), ($50,$15,$ff,$60), + ($98,$fb,$24,$19), ($bd,$e9,$97,$d6), ($40,$43,$cc,$89), ($d9,$9e,$77,$67), + ($e8,$42,$bd,$b0), ($89,$8b,$88,$07), ($19,$5b,$38,$e7), ($c8,$ee,$db,$79), + ($7c,$0a,$47,$a1), ($42,$0f,$e9,$7c), ($84,$1e,$c9,$f8), ($00,$00,$00,$00), + ($80,$86,$83,$09), ($2b,$ed,$48,$32), ($11,$70,$ac,$1e), ($5a,$72,$4e,$6c), + ($0e,$ff,$fb,$fd), ($85,$38,$56,$0f), ($ae,$d5,$1e,$3d), ($2d,$39,$27,$36), + ($0f,$d9,$64,$0a), ($5c,$a6,$21,$68), ($5b,$54,$d1,$9b), ($36,$2e,$3a,$24), + ($0a,$67,$b1,$0c), ($57,$e7,$0f,$93), ($ee,$96,$d2,$b4), ($9b,$91,$9e,$1b), + ($c0,$c5,$4f,$80), ($dc,$20,$a2,$61), ($77,$4b,$69,$5a), ($12,$1a,$16,$1c), + ($93,$ba,$0a,$e2), ($a0,$2a,$e5,$c0), ($22,$e0,$43,$3c), ($1b,$17,$1d,$12), + ($09,$0d,$0b,$0e), ($8b,$c7,$ad,$f2), ($b6,$a8,$b9,$2d), ($1e,$a9,$c8,$14), + ($f1,$19,$85,$57), ($75,$07,$4c,$af), ($99,$dd,$bb,$ee), ($7f,$60,$fd,$a3), + ($01,$26,$9f,$f7), ($72,$f5,$bc,$5c), ($66,$3b,$c5,$44), ($fb,$7e,$34,$5b), + ($43,$29,$76,$8b), ($23,$c6,$dc,$cb), ($ed,$fc,$68,$b6), ($e4,$f1,$63,$b8), + ($31,$dc,$ca,$d7), ($63,$85,$10,$42), ($97,$22,$40,$13), ($c6,$11,$20,$84), + ($4a,$24,$7d,$85), ($bb,$3d,$f8,$d2), ($f9,$32,$11,$ae), ($29,$a1,$6d,$c7), + ($9e,$2f,$4b,$1d), ($b2,$30,$f3,$dc), ($86,$52,$ec,$0d), ($c1,$e3,$d0,$77), + ($b3,$16,$6c,$2b), ($70,$b9,$99,$a9), ($94,$48,$fa,$11), ($e9,$64,$22,$47), + ($fc,$8c,$c4,$a8), ($f0,$3f,$1a,$a0), ($7d,$2c,$d8,$56), ($33,$90,$ef,$22), + ($49,$4e,$c7,$87), ($38,$d1,$c1,$d9), ($ca,$a2,$fe,$8c), ($d4,$0b,$36,$98), + ($f5,$81,$cf,$a6), ($7a,$de,$28,$a5), ($b7,$8e,$26,$da), ($ad,$bf,$a4,$3f), + ($3a,$9d,$e4,$2c), ($78,$92,$0d,$50), ($5f,$cc,$9b,$6a), ($7e,$46,$62,$54), + ($8d,$13,$c2,$f6), ($d8,$b8,$e8,$90), ($39,$f7,$5e,$2e), ($c3,$af,$f5,$82), + ($5d,$80,$be,$9f), ($d0,$93,$7c,$69), ($d5,$2d,$a9,$6f), ($25,$12,$b3,$cf), + ($ac,$99,$3b,$c8), ($18,$7d,$a7,$10), ($9c,$63,$6e,$e8), ($3b,$bb,$7b,$db), + ($26,$78,$09,$cd), ($59,$18,$f4,$6e), ($9a,$b7,$01,$ec), ($4f,$9a,$a8,$83), + ($95,$6e,$65,$e6), ($ff,$e6,$7e,$aa), ($bc,$cf,$08,$21), ($15,$e8,$e6,$ef), + ($e7,$9b,$d9,$ba), ($6f,$36,$ce,$4a), ($9f,$09,$d4,$ea), ($b0,$7c,$d6,$29), + ($a4,$b2,$af,$31), ($3f,$23,$31,$2a), ($a5,$94,$30,$c6), ($a2,$66,$c0,$35), + ($4e,$bc,$37,$74), ($82,$ca,$a6,$fc), ($90,$d0,$b0,$e0), ($a7,$d8,$15,$33), + ($04,$98,$4a,$f1), ($ec,$da,$f7,$41), ($cd,$50,$0e,$7f), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($ef,$b0,$4d,$43), ($aa,$4d,$54,$cc), ($96,$04,$df,$e4), + ($d1,$b5,$e3,$9e), ($6a,$88,$1b,$4c), ($2c,$1f,$b8,$c1), ($65,$51,$7f,$46), + ($5e,$ea,$04,$9d), ($8c,$35,$5d,$01), ($87,$74,$73,$fa), ($0b,$41,$2e,$fb), + ($67,$1d,$5a,$b3), ($db,$d2,$52,$92), ($10,$56,$33,$e9), ($d6,$47,$13,$6d), + ($d7,$61,$8c,$9a), ($a1,$0c,$7a,$37), ($f8,$14,$8e,$59), ($13,$3c,$89,$eb), + ($a9,$27,$ee,$ce), ($61,$c9,$35,$b7), ($1c,$e5,$ed,$e1), ($47,$b1,$3c,$7a), + ($d2,$df,$59,$9c), ($f2,$73,$3f,$55), ($14,$ce,$79,$18), ($c7,$37,$bf,$73), + ($f7,$cd,$ea,$53), ($fd,$aa,$5b,$5f), ($3d,$6f,$14,$df), ($44,$db,$86,$78), + ($af,$f3,$81,$ca), ($68,$c4,$3e,$b9), ($24,$34,$2c,$38), ($a3,$40,$5f,$c2), + ($1d,$c3,$72,$16), ($e2,$25,$0c,$bc), ($3c,$49,$8b,$28), ($0d,$95,$41,$ff), + ($a8,$01,$71,$39), ($0c,$b3,$de,$08), ($b4,$e4,$9c,$d8), ($56,$c1,$90,$64), + ($cb,$84,$61,$7b), ($32,$b6,$70,$d5), ($6c,$5c,$74,$48), ($b8,$57,$42,$d0)); + S5: array[0..255] of byte= ( + $52,$09,$6a,$d5, + $30,$36,$a5,$38, + $bf,$40,$a3,$9e, + $81,$f3,$d7,$fb, + $7c,$e3,$39,$82, + $9b,$2f,$ff,$87, + $34,$8e,$43,$44, + $c4,$de,$e9,$cb, + $54,$7b,$94,$32, + $a6,$c2,$23,$3d, + $ee,$4c,$95,$0b, + $42,$fa,$c3,$4e, + $08,$2e,$a1,$66, + $28,$d9,$24,$b2, + $76,$5b,$a2,$49, + $6d,$8b,$d1,$25, + $72,$f8,$f6,$64, + $86,$68,$98,$16, + $d4,$a4,$5c,$cc, + $5d,$65,$b6,$92, + $6c,$70,$48,$50, + $fd,$ed,$b9,$da, + $5e,$15,$46,$57, + $a7,$8d,$9d,$84, + $90,$d8,$ab,$00, + $8c,$bc,$d3,$0a, + $f7,$e4,$58,$05, + $b8,$b3,$45,$06, + $d0,$2c,$1e,$8f, + $ca,$3f,$0f,$02, + $c1,$af,$bd,$03, + $01,$13,$8a,$6b, + $3a,$91,$11,$41, + $4f,$67,$dc,$ea, + $97,$f2,$cf,$ce, + $f0,$b4,$e6,$73, + $96,$ac,$74,$22, + $e7,$ad,$35,$85, + $e2,$f9,$37,$e8, + $1c,$75,$df,$6e, + $47,$f1,$1a,$71, + $1d,$29,$c5,$89, + $6f,$b7,$62,$0e, + $aa,$18,$be,$1b, + $fc,$56,$3e,$4b, + $c6,$d2,$79,$20, + $9a,$db,$c0,$fe, + $78,$cd,$5a,$f4, + $1f,$dd,$a8,$33, + $88,$07,$c7,$31, + $b1,$12,$10,$59, + $27,$80,$ec,$5f, + $60,$51,$7f,$a9, + $19,$b5,$4a,$0d, + $2d,$e5,$7a,$9f, + $93,$c9,$9c,$ef, + $a0,$e0,$3b,$4d, + $ae,$2a,$f5,$b0, + $c8,$eb,$bb,$3c, + $83,$53,$99,$61, + $17,$2b,$04,$7e, + $ba,$77,$d6,$26, + $e1,$69,$14,$63, + $55,$21,$0c,$7d); + U1: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0e,$09,$0d,$0b), ($1c,$12,$1a,$16), ($12,$1b,$17,$1d), + ($38,$24,$34,$2c), ($36,$2d,$39,$27), ($24,$36,$2e,$3a), ($2a,$3f,$23,$31), + ($70,$48,$68,$58), ($7e,$41,$65,$53), ($6c,$5a,$72,$4e), ($62,$53,$7f,$45), + ($48,$6c,$5c,$74), ($46,$65,$51,$7f), ($54,$7e,$46,$62), ($5a,$77,$4b,$69), + ($e0,$90,$d0,$b0), ($ee,$99,$dd,$bb), ($fc,$82,$ca,$a6), ($f2,$8b,$c7,$ad), + ($d8,$b4,$e4,$9c), ($d6,$bd,$e9,$97), ($c4,$a6,$fe,$8a), ($ca,$af,$f3,$81), + ($90,$d8,$b8,$e8), ($9e,$d1,$b5,$e3), ($8c,$ca,$a2,$fe), ($82,$c3,$af,$f5), + ($a8,$fc,$8c,$c4), ($a6,$f5,$81,$cf), ($b4,$ee,$96,$d2), ($ba,$e7,$9b,$d9), + ($db,$3b,$bb,$7b), ($d5,$32,$b6,$70), ($c7,$29,$a1,$6d), ($c9,$20,$ac,$66), + ($e3,$1f,$8f,$57), ($ed,$16,$82,$5c), ($ff,$0d,$95,$41), ($f1,$04,$98,$4a), + ($ab,$73,$d3,$23), ($a5,$7a,$de,$28), ($b7,$61,$c9,$35), ($b9,$68,$c4,$3e), + ($93,$57,$e7,$0f), ($9d,$5e,$ea,$04), ($8f,$45,$fd,$19), ($81,$4c,$f0,$12), + ($3b,$ab,$6b,$cb), ($35,$a2,$66,$c0), ($27,$b9,$71,$dd), ($29,$b0,$7c,$d6), + ($03,$8f,$5f,$e7), ($0d,$86,$52,$ec), ($1f,$9d,$45,$f1), ($11,$94,$48,$fa), + ($4b,$e3,$03,$93), ($45,$ea,$0e,$98), ($57,$f1,$19,$85), ($59,$f8,$14,$8e), + ($73,$c7,$37,$bf), ($7d,$ce,$3a,$b4), ($6f,$d5,$2d,$a9), ($61,$dc,$20,$a2), + ($ad,$76,$6d,$f6), ($a3,$7f,$60,$fd), ($b1,$64,$77,$e0), ($bf,$6d,$7a,$eb), + ($95,$52,$59,$da), ($9b,$5b,$54,$d1), ($89,$40,$43,$cc), ($87,$49,$4e,$c7), + ($dd,$3e,$05,$ae), ($d3,$37,$08,$a5), ($c1,$2c,$1f,$b8), ($cf,$25,$12,$b3), + ($e5,$1a,$31,$82), ($eb,$13,$3c,$89), ($f9,$08,$2b,$94), ($f7,$01,$26,$9f), + ($4d,$e6,$bd,$46), ($43,$ef,$b0,$4d), ($51,$f4,$a7,$50), ($5f,$fd,$aa,$5b), + ($75,$c2,$89,$6a), ($7b,$cb,$84,$61), ($69,$d0,$93,$7c), ($67,$d9,$9e,$77), + ($3d,$ae,$d5,$1e), ($33,$a7,$d8,$15), ($21,$bc,$cf,$08), ($2f,$b5,$c2,$03), + ($05,$8a,$e1,$32), ($0b,$83,$ec,$39), ($19,$98,$fb,$24), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($78,$44,$db,$86), ($6a,$5f,$cc,$9b), ($64,$56,$c1,$90), + ($4e,$69,$e2,$a1), ($40,$60,$ef,$aa), ($52,$7b,$f8,$b7), ($5c,$72,$f5,$bc), + ($06,$05,$be,$d5), ($08,$0c,$b3,$de), ($1a,$17,$a4,$c3), ($14,$1e,$a9,$c8), + ($3e,$21,$8a,$f9), ($30,$28,$87,$f2), ($22,$33,$90,$ef), ($2c,$3a,$9d,$e4), + ($96,$dd,$06,$3d), ($98,$d4,$0b,$36), ($8a,$cf,$1c,$2b), ($84,$c6,$11,$20), + ($ae,$f9,$32,$11), ($a0,$f0,$3f,$1a), ($b2,$eb,$28,$07), ($bc,$e2,$25,$0c), + ($e6,$95,$6e,$65), ($e8,$9c,$63,$6e), ($fa,$87,$74,$73), ($f4,$8e,$79,$78), + ($de,$b1,$5a,$49), ($d0,$b8,$57,$42), ($c2,$a3,$40,$5f), ($cc,$aa,$4d,$54), + ($41,$ec,$da,$f7), ($4f,$e5,$d7,$fc), ($5d,$fe,$c0,$e1), ($53,$f7,$cd,$ea), + ($79,$c8,$ee,$db), ($77,$c1,$e3,$d0), ($65,$da,$f4,$cd), ($6b,$d3,$f9,$c6), + ($31,$a4,$b2,$af), ($3f,$ad,$bf,$a4), ($2d,$b6,$a8,$b9), ($23,$bf,$a5,$b2), + ($09,$80,$86,$83), ($07,$89,$8b,$88), ($15,$92,$9c,$95), ($1b,$9b,$91,$9e), + ($a1,$7c,$0a,$47), ($af,$75,$07,$4c), ($bd,$6e,$10,$51), ($b3,$67,$1d,$5a), + ($99,$58,$3e,$6b), ($97,$51,$33,$60), ($85,$4a,$24,$7d), ($8b,$43,$29,$76), + ($d1,$34,$62,$1f), ($df,$3d,$6f,$14), ($cd,$26,$78,$09), ($c3,$2f,$75,$02), + ($e9,$10,$56,$33), ($e7,$19,$5b,$38), ($f5,$02,$4c,$25), ($fb,$0b,$41,$2e), + ($9a,$d7,$61,$8c), ($94,$de,$6c,$87), ($86,$c5,$7b,$9a), ($88,$cc,$76,$91), + ($a2,$f3,$55,$a0), ($ac,$fa,$58,$ab), ($be,$e1,$4f,$b6), ($b0,$e8,$42,$bd), + ($ea,$9f,$09,$d4), ($e4,$96,$04,$df), ($f6,$8d,$13,$c2), ($f8,$84,$1e,$c9), + ($d2,$bb,$3d,$f8), ($dc,$b2,$30,$f3), ($ce,$a9,$27,$ee), ($c0,$a0,$2a,$e5), + ($7a,$47,$b1,$3c), ($74,$4e,$bc,$37), ($66,$55,$ab,$2a), ($68,$5c,$a6,$21), + ($42,$63,$85,$10), ($4c,$6a,$88,$1b), ($5e,$71,$9f,$06), ($50,$78,$92,$0d), + ($0a,$0f,$d9,$64), ($04,$06,$d4,$6f), ($16,$1d,$c3,$72), ($18,$14,$ce,$79), + ($32,$2b,$ed,$48), ($3c,$22,$e0,$43), ($2e,$39,$f7,$5e), ($20,$30,$fa,$55), + ($ec,$9a,$b7,$01), ($e2,$93,$ba,$0a), ($f0,$88,$ad,$17), ($fe,$81,$a0,$1c), + ($d4,$be,$83,$2d), ($da,$b7,$8e,$26), ($c8,$ac,$99,$3b), ($c6,$a5,$94,$30), + ($9c,$d2,$df,$59), ($92,$db,$d2,$52), ($80,$c0,$c5,$4f), ($8e,$c9,$c8,$44), + ($a4,$f6,$eb,$75), ($aa,$ff,$e6,$7e), ($b8,$e4,$f1,$63), ($b6,$ed,$fc,$68), + ($0c,$0a,$67,$b1), ($02,$03,$6a,$ba), ($10,$18,$7d,$a7), ($1e,$11,$70,$ac), + ($34,$2e,$53,$9d), ($3a,$27,$5e,$96), ($28,$3c,$49,$8b), ($26,$35,$44,$80), + ($7c,$42,$0f,$e9), ($72,$4b,$02,$e2), ($60,$50,$15,$ff), ($6e,$59,$18,$f4), + ($44,$66,$3b,$c5), ($4a,$6f,$36,$ce), ($58,$74,$21,$d3), ($56,$7d,$2c,$d8), + ($37,$a1,$0c,$7a), ($39,$a8,$01,$71), ($2b,$b3,$16,$6c), ($25,$ba,$1b,$67), + ($0f,$85,$38,$56), ($01,$8c,$35,$5d), ($13,$97,$22,$40), ($1d,$9e,$2f,$4b), + ($47,$e9,$64,$22), ($49,$e0,$69,$29), ($5b,$fb,$7e,$34), ($55,$f2,$73,$3f), + ($7f,$cd,$50,$0e), ($71,$c4,$5d,$05), ($63,$df,$4a,$18), ($6d,$d6,$47,$13), + ($d7,$31,$dc,$ca), ($d9,$38,$d1,$c1), ($cb,$23,$c6,$dc), ($c5,$2a,$cb,$d7), + ($ef,$15,$e8,$e6), ($e1,$1c,$e5,$ed), ($f3,$07,$f2,$f0), ($fd,$0e,$ff,$fb), + ($a7,$79,$b4,$92), ($a9,$70,$b9,$99), ($bb,$6b,$ae,$84), ($b5,$62,$a3,$8f), + ($9f,$5d,$80,$be), ($91,$54,$8d,$b5), ($83,$4f,$9a,$a8), ($8d,$46,$97,$a3)); + U2: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0b,$0e,$09,$0d), ($16,$1c,$12,$1a), ($1d,$12,$1b,$17), + ($2c,$38,$24,$34), ($27,$36,$2d,$39), ($3a,$24,$36,$2e), ($31,$2a,$3f,$23), + ($58,$70,$48,$68), ($53,$7e,$41,$65), ($4e,$6c,$5a,$72), ($45,$62,$53,$7f), + ($74,$48,$6c,$5c), ($7f,$46,$65,$51), ($62,$54,$7e,$46), ($69,$5a,$77,$4b), + ($b0,$e0,$90,$d0), ($bb,$ee,$99,$dd), ($a6,$fc,$82,$ca), ($ad,$f2,$8b,$c7), + ($9c,$d8,$b4,$e4), ($97,$d6,$bd,$e9), ($8a,$c4,$a6,$fe), ($81,$ca,$af,$f3), + ($e8,$90,$d8,$b8), ($e3,$9e,$d1,$b5), ($fe,$8c,$ca,$a2), ($f5,$82,$c3,$af), + ($c4,$a8,$fc,$8c), ($cf,$a6,$f5,$81), ($d2,$b4,$ee,$96), ($d9,$ba,$e7,$9b), + ($7b,$db,$3b,$bb), ($70,$d5,$32,$b6), ($6d,$c7,$29,$a1), ($66,$c9,$20,$ac), + ($57,$e3,$1f,$8f), ($5c,$ed,$16,$82), ($41,$ff,$0d,$95), ($4a,$f1,$04,$98), + ($23,$ab,$73,$d3), ($28,$a5,$7a,$de), ($35,$b7,$61,$c9), ($3e,$b9,$68,$c4), + ($0f,$93,$57,$e7), ($04,$9d,$5e,$ea), ($19,$8f,$45,$fd), ($12,$81,$4c,$f0), + ($cb,$3b,$ab,$6b), ($c0,$35,$a2,$66), ($dd,$27,$b9,$71), ($d6,$29,$b0,$7c), + ($e7,$03,$8f,$5f), ($ec,$0d,$86,$52), ($f1,$1f,$9d,$45), ($fa,$11,$94,$48), + ($93,$4b,$e3,$03), ($98,$45,$ea,$0e), ($85,$57,$f1,$19), ($8e,$59,$f8,$14), + ($bf,$73,$c7,$37), ($b4,$7d,$ce,$3a), ($a9,$6f,$d5,$2d), ($a2,$61,$dc,$20), + ($f6,$ad,$76,$6d), ($fd,$a3,$7f,$60), ($e0,$b1,$64,$77), ($eb,$bf,$6d,$7a), + ($da,$95,$52,$59), ($d1,$9b,$5b,$54), ($cc,$89,$40,$43), ($c7,$87,$49,$4e), + ($ae,$dd,$3e,$05), ($a5,$d3,$37,$08), ($b8,$c1,$2c,$1f), ($b3,$cf,$25,$12), + ($82,$e5,$1a,$31), ($89,$eb,$13,$3c), ($94,$f9,$08,$2b), ($9f,$f7,$01,$26), + ($46,$4d,$e6,$bd), ($4d,$43,$ef,$b0), ($50,$51,$f4,$a7), ($5b,$5f,$fd,$aa), + ($6a,$75,$c2,$89), ($61,$7b,$cb,$84), ($7c,$69,$d0,$93), ($77,$67,$d9,$9e), + ($1e,$3d,$ae,$d5), ($15,$33,$a7,$d8), ($08,$21,$bc,$cf), ($03,$2f,$b5,$c2), + ($32,$05,$8a,$e1), ($39,$0b,$83,$ec), ($24,$19,$98,$fb), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($86,$78,$44,$db), ($9b,$6a,$5f,$cc), ($90,$64,$56,$c1), + ($a1,$4e,$69,$e2), ($aa,$40,$60,$ef), ($b7,$52,$7b,$f8), ($bc,$5c,$72,$f5), + ($d5,$06,$05,$be), ($de,$08,$0c,$b3), ($c3,$1a,$17,$a4), ($c8,$14,$1e,$a9), + ($f9,$3e,$21,$8a), ($f2,$30,$28,$87), ($ef,$22,$33,$90), ($e4,$2c,$3a,$9d), + ($3d,$96,$dd,$06), ($36,$98,$d4,$0b), ($2b,$8a,$cf,$1c), ($20,$84,$c6,$11), + ($11,$ae,$f9,$32), ($1a,$a0,$f0,$3f), ($07,$b2,$eb,$28), ($0c,$bc,$e2,$25), + ($65,$e6,$95,$6e), ($6e,$e8,$9c,$63), ($73,$fa,$87,$74), ($78,$f4,$8e,$79), + ($49,$de,$b1,$5a), ($42,$d0,$b8,$57), ($5f,$c2,$a3,$40), ($54,$cc,$aa,$4d), + ($f7,$41,$ec,$da), ($fc,$4f,$e5,$d7), ($e1,$5d,$fe,$c0), ($ea,$53,$f7,$cd), + ($db,$79,$c8,$ee), ($d0,$77,$c1,$e3), ($cd,$65,$da,$f4), ($c6,$6b,$d3,$f9), + ($af,$31,$a4,$b2), ($a4,$3f,$ad,$bf), ($b9,$2d,$b6,$a8), ($b2,$23,$bf,$a5), + ($83,$09,$80,$86), ($88,$07,$89,$8b), ($95,$15,$92,$9c), ($9e,$1b,$9b,$91), + ($47,$a1,$7c,$0a), ($4c,$af,$75,$07), ($51,$bd,$6e,$10), ($5a,$b3,$67,$1d), + ($6b,$99,$58,$3e), ($60,$97,$51,$33), ($7d,$85,$4a,$24), ($76,$8b,$43,$29), + ($1f,$d1,$34,$62), ($14,$df,$3d,$6f), ($09,$cd,$26,$78), ($02,$c3,$2f,$75), + ($33,$e9,$10,$56), ($38,$e7,$19,$5b), ($25,$f5,$02,$4c), ($2e,$fb,$0b,$41), + ($8c,$9a,$d7,$61), ($87,$94,$de,$6c), ($9a,$86,$c5,$7b), ($91,$88,$cc,$76), + ($a0,$a2,$f3,$55), ($ab,$ac,$fa,$58), ($b6,$be,$e1,$4f), ($bd,$b0,$e8,$42), + ($d4,$ea,$9f,$09), ($df,$e4,$96,$04), ($c2,$f6,$8d,$13), ($c9,$f8,$84,$1e), + ($f8,$d2,$bb,$3d), ($f3,$dc,$b2,$30), ($ee,$ce,$a9,$27), ($e5,$c0,$a0,$2a), + ($3c,$7a,$47,$b1), ($37,$74,$4e,$bc), ($2a,$66,$55,$ab), ($21,$68,$5c,$a6), + ($10,$42,$63,$85), ($1b,$4c,$6a,$88), ($06,$5e,$71,$9f), ($0d,$50,$78,$92), + ($64,$0a,$0f,$d9), ($6f,$04,$06,$d4), ($72,$16,$1d,$c3), ($79,$18,$14,$ce), + ($48,$32,$2b,$ed), ($43,$3c,$22,$e0), ($5e,$2e,$39,$f7), ($55,$20,$30,$fa), + ($01,$ec,$9a,$b7), ($0a,$e2,$93,$ba), ($17,$f0,$88,$ad), ($1c,$fe,$81,$a0), + ($2d,$d4,$be,$83), ($26,$da,$b7,$8e), ($3b,$c8,$ac,$99), ($30,$c6,$a5,$94), + ($59,$9c,$d2,$df), ($52,$92,$db,$d2), ($4f,$80,$c0,$c5), ($44,$8e,$c9,$c8), + ($75,$a4,$f6,$eb), ($7e,$aa,$ff,$e6), ($63,$b8,$e4,$f1), ($68,$b6,$ed,$fc), + ($b1,$0c,$0a,$67), ($ba,$02,$03,$6a), ($a7,$10,$18,$7d), ($ac,$1e,$11,$70), + ($9d,$34,$2e,$53), ($96,$3a,$27,$5e), ($8b,$28,$3c,$49), ($80,$26,$35,$44), + ($e9,$7c,$42,$0f), ($e2,$72,$4b,$02), ($ff,$60,$50,$15), ($f4,$6e,$59,$18), + ($c5,$44,$66,$3b), ($ce,$4a,$6f,$36), ($d3,$58,$74,$21), ($d8,$56,$7d,$2c), + ($7a,$37,$a1,$0c), ($71,$39,$a8,$01), ($6c,$2b,$b3,$16), ($67,$25,$ba,$1b), + ($56,$0f,$85,$38), ($5d,$01,$8c,$35), ($40,$13,$97,$22), ($4b,$1d,$9e,$2f), + ($22,$47,$e9,$64), ($29,$49,$e0,$69), ($34,$5b,$fb,$7e), ($3f,$55,$f2,$73), + ($0e,$7f,$cd,$50), ($05,$71,$c4,$5d), ($18,$63,$df,$4a), ($13,$6d,$d6,$47), + ($ca,$d7,$31,$dc), ($c1,$d9,$38,$d1), ($dc,$cb,$23,$c6), ($d7,$c5,$2a,$cb), + ($e6,$ef,$15,$e8), ($ed,$e1,$1c,$e5), ($f0,$f3,$07,$f2), ($fb,$fd,$0e,$ff), + ($92,$a7,$79,$b4), ($99,$a9,$70,$b9), ($84,$bb,$6b,$ae), ($8f,$b5,$62,$a3), + ($be,$9f,$5d,$80), ($b5,$91,$54,$8d), ($a8,$83,$4f,$9a), ($a3,$8d,$46,$97)); + U3: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0d,$0b,$0e,$09), ($1a,$16,$1c,$12), ($17,$1d,$12,$1b), + ($34,$2c,$38,$24), ($39,$27,$36,$2d), ($2e,$3a,$24,$36), ($23,$31,$2a,$3f), + ($68,$58,$70,$48), ($65,$53,$7e,$41), ($72,$4e,$6c,$5a), ($7f,$45,$62,$53), + ($5c,$74,$48,$6c), ($51,$7f,$46,$65), ($46,$62,$54,$7e), ($4b,$69,$5a,$77), + ($d0,$b0,$e0,$90), ($dd,$bb,$ee,$99), ($ca,$a6,$fc,$82), ($c7,$ad,$f2,$8b), + ($e4,$9c,$d8,$b4), ($e9,$97,$d6,$bd), ($fe,$8a,$c4,$a6), ($f3,$81,$ca,$af), + ($b8,$e8,$90,$d8), ($b5,$e3,$9e,$d1), ($a2,$fe,$8c,$ca), ($af,$f5,$82,$c3), + ($8c,$c4,$a8,$fc), ($81,$cf,$a6,$f5), ($96,$d2,$b4,$ee), ($9b,$d9,$ba,$e7), + ($bb,$7b,$db,$3b), ($b6,$70,$d5,$32), ($a1,$6d,$c7,$29), ($ac,$66,$c9,$20), + ($8f,$57,$e3,$1f), ($82,$5c,$ed,$16), ($95,$41,$ff,$0d), ($98,$4a,$f1,$04), + ($d3,$23,$ab,$73), ($de,$28,$a5,$7a), ($c9,$35,$b7,$61), ($c4,$3e,$b9,$68), + ($e7,$0f,$93,$57), ($ea,$04,$9d,$5e), ($fd,$19,$8f,$45), ($f0,$12,$81,$4c), + ($6b,$cb,$3b,$ab), ($66,$c0,$35,$a2), ($71,$dd,$27,$b9), ($7c,$d6,$29,$b0), + ($5f,$e7,$03,$8f), ($52,$ec,$0d,$86), ($45,$f1,$1f,$9d), ($48,$fa,$11,$94), + ($03,$93,$4b,$e3), ($0e,$98,$45,$ea), ($19,$85,$57,$f1), ($14,$8e,$59,$f8), + ($37,$bf,$73,$c7), ($3a,$b4,$7d,$ce), ($2d,$a9,$6f,$d5), ($20,$a2,$61,$dc), + ($6d,$f6,$ad,$76), ($60,$fd,$a3,$7f), ($77,$e0,$b1,$64), ($7a,$eb,$bf,$6d), + ($59,$da,$95,$52), ($54,$d1,$9b,$5b), ($43,$cc,$89,$40), ($4e,$c7,$87,$49), + ($05,$ae,$dd,$3e), ($08,$a5,$d3,$37), ($1f,$b8,$c1,$2c), ($12,$b3,$cf,$25), + ($31,$82,$e5,$1a), ($3c,$89,$eb,$13), ($2b,$94,$f9,$08), ($26,$9f,$f7,$01), + ($bd,$46,$4d,$e6), ($b0,$4d,$43,$ef), ($a7,$50,$51,$f4), ($aa,$5b,$5f,$fd), + ($89,$6a,$75,$c2), ($84,$61,$7b,$cb), ($93,$7c,$69,$d0), ($9e,$77,$67,$d9), + ($d5,$1e,$3d,$ae), ($d8,$15,$33,$a7), ($cf,$08,$21,$bc), ($c2,$03,$2f,$b5), + ($e1,$32,$05,$8a), ($ec,$39,$0b,$83), ($fb,$24,$19,$98), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($db,$86,$78,$44), ($cc,$9b,$6a,$5f), ($c1,$90,$64,$56), + ($e2,$a1,$4e,$69), ($ef,$aa,$40,$60), ($f8,$b7,$52,$7b), ($f5,$bc,$5c,$72), + ($be,$d5,$06,$05), ($b3,$de,$08,$0c), ($a4,$c3,$1a,$17), ($a9,$c8,$14,$1e), + ($8a,$f9,$3e,$21), ($87,$f2,$30,$28), ($90,$ef,$22,$33), ($9d,$e4,$2c,$3a), + ($06,$3d,$96,$dd), ($0b,$36,$98,$d4), ($1c,$2b,$8a,$cf), ($11,$20,$84,$c6), + ($32,$11,$ae,$f9), ($3f,$1a,$a0,$f0), ($28,$07,$b2,$eb), ($25,$0c,$bc,$e2), + ($6e,$65,$e6,$95), ($63,$6e,$e8,$9c), ($74,$73,$fa,$87), ($79,$78,$f4,$8e), + ($5a,$49,$de,$b1), ($57,$42,$d0,$b8), ($40,$5f,$c2,$a3), ($4d,$54,$cc,$aa), + ($da,$f7,$41,$ec), ($d7,$fc,$4f,$e5), ($c0,$e1,$5d,$fe), ($cd,$ea,$53,$f7), + ($ee,$db,$79,$c8), ($e3,$d0,$77,$c1), ($f4,$cd,$65,$da), ($f9,$c6,$6b,$d3), + ($b2,$af,$31,$a4), ($bf,$a4,$3f,$ad), ($a8,$b9,$2d,$b6), ($a5,$b2,$23,$bf), + ($86,$83,$09,$80), ($8b,$88,$07,$89), ($9c,$95,$15,$92), ($91,$9e,$1b,$9b), + ($0a,$47,$a1,$7c), ($07,$4c,$af,$75), ($10,$51,$bd,$6e), ($1d,$5a,$b3,$67), + ($3e,$6b,$99,$58), ($33,$60,$97,$51), ($24,$7d,$85,$4a), ($29,$76,$8b,$43), + ($62,$1f,$d1,$34), ($6f,$14,$df,$3d), ($78,$09,$cd,$26), ($75,$02,$c3,$2f), + ($56,$33,$e9,$10), ($5b,$38,$e7,$19), ($4c,$25,$f5,$02), ($41,$2e,$fb,$0b), + ($61,$8c,$9a,$d7), ($6c,$87,$94,$de), ($7b,$9a,$86,$c5), ($76,$91,$88,$cc), + ($55,$a0,$a2,$f3), ($58,$ab,$ac,$fa), ($4f,$b6,$be,$e1), ($42,$bd,$b0,$e8), + ($09,$d4,$ea,$9f), ($04,$df,$e4,$96), ($13,$c2,$f6,$8d), ($1e,$c9,$f8,$84), + ($3d,$f8,$d2,$bb), ($30,$f3,$dc,$b2), ($27,$ee,$ce,$a9), ($2a,$e5,$c0,$a0), + ($b1,$3c,$7a,$47), ($bc,$37,$74,$4e), ($ab,$2a,$66,$55), ($a6,$21,$68,$5c), + ($85,$10,$42,$63), ($88,$1b,$4c,$6a), ($9f,$06,$5e,$71), ($92,$0d,$50,$78), + ($d9,$64,$0a,$0f), ($d4,$6f,$04,$06), ($c3,$72,$16,$1d), ($ce,$79,$18,$14), + ($ed,$48,$32,$2b), ($e0,$43,$3c,$22), ($f7,$5e,$2e,$39), ($fa,$55,$20,$30), + ($b7,$01,$ec,$9a), ($ba,$0a,$e2,$93), ($ad,$17,$f0,$88), ($a0,$1c,$fe,$81), + ($83,$2d,$d4,$be), ($8e,$26,$da,$b7), ($99,$3b,$c8,$ac), ($94,$30,$c6,$a5), + ($df,$59,$9c,$d2), ($d2,$52,$92,$db), ($c5,$4f,$80,$c0), ($c8,$44,$8e,$c9), + ($eb,$75,$a4,$f6), ($e6,$7e,$aa,$ff), ($f1,$63,$b8,$e4), ($fc,$68,$b6,$ed), + ($67,$b1,$0c,$0a), ($6a,$ba,$02,$03), ($7d,$a7,$10,$18), ($70,$ac,$1e,$11), + ($53,$9d,$34,$2e), ($5e,$96,$3a,$27), ($49,$8b,$28,$3c), ($44,$80,$26,$35), + ($0f,$e9,$7c,$42), ($02,$e2,$72,$4b), ($15,$ff,$60,$50), ($18,$f4,$6e,$59), + ($3b,$c5,$44,$66), ($36,$ce,$4a,$6f), ($21,$d3,$58,$74), ($2c,$d8,$56,$7d), + ($0c,$7a,$37,$a1), ($01,$71,$39,$a8), ($16,$6c,$2b,$b3), ($1b,$67,$25,$ba), + ($38,$56,$0f,$85), ($35,$5d,$01,$8c), ($22,$40,$13,$97), ($2f,$4b,$1d,$9e), + ($64,$22,$47,$e9), ($69,$29,$49,$e0), ($7e,$34,$5b,$fb), ($73,$3f,$55,$f2), + ($50,$0e,$7f,$cd), ($5d,$05,$71,$c4), ($4a,$18,$63,$df), ($47,$13,$6d,$d6), + ($dc,$ca,$d7,$31), ($d1,$c1,$d9,$38), ($c6,$dc,$cb,$23), ($cb,$d7,$c5,$2a), + ($e8,$e6,$ef,$15), ($e5,$ed,$e1,$1c), ($f2,$f0,$f3,$07), ($ff,$fb,$fd,$0e), + ($b4,$92,$a7,$79), ($b9,$99,$a9,$70), ($ae,$84,$bb,$6b), ($a3,$8f,$b5,$62), + ($80,$be,$9f,$5d), ($8d,$b5,$91,$54), ($9a,$a8,$83,$4f), ($97,$a3,$8d,$46)); + U4: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($09,$0d,$0b,$0e), ($12,$1a,$16,$1c), ($1b,$17,$1d,$12), + ($24,$34,$2c,$38), ($2d,$39,$27,$36), ($36,$2e,$3a,$24), ($3f,$23,$31,$2a), + ($48,$68,$58,$70), ($41,$65,$53,$7e), ($5a,$72,$4e,$6c), ($53,$7f,$45,$62), + ($6c,$5c,$74,$48), ($65,$51,$7f,$46), ($7e,$46,$62,$54), ($77,$4b,$69,$5a), + ($90,$d0,$b0,$e0), ($99,$dd,$bb,$ee), ($82,$ca,$a6,$fc), ($8b,$c7,$ad,$f2), + ($b4,$e4,$9c,$d8), ($bd,$e9,$97,$d6), ($a6,$fe,$8a,$c4), ($af,$f3,$81,$ca), + ($d8,$b8,$e8,$90), ($d1,$b5,$e3,$9e), ($ca,$a2,$fe,$8c), ($c3,$af,$f5,$82), + ($fc,$8c,$c4,$a8), ($f5,$81,$cf,$a6), ($ee,$96,$d2,$b4), ($e7,$9b,$d9,$ba), + ($3b,$bb,$7b,$db), ($32,$b6,$70,$d5), ($29,$a1,$6d,$c7), ($20,$ac,$66,$c9), + ($1f,$8f,$57,$e3), ($16,$82,$5c,$ed), ($0d,$95,$41,$ff), ($04,$98,$4a,$f1), + ($73,$d3,$23,$ab), ($7a,$de,$28,$a5), ($61,$c9,$35,$b7), ($68,$c4,$3e,$b9), + ($57,$e7,$0f,$93), ($5e,$ea,$04,$9d), ($45,$fd,$19,$8f), ($4c,$f0,$12,$81), + ($ab,$6b,$cb,$3b), ($a2,$66,$c0,$35), ($b9,$71,$dd,$27), ($b0,$7c,$d6,$29), + ($8f,$5f,$e7,$03), ($86,$52,$ec,$0d), ($9d,$45,$f1,$1f), ($94,$48,$fa,$11), + ($e3,$03,$93,$4b), ($ea,$0e,$98,$45), ($f1,$19,$85,$57), ($f8,$14,$8e,$59), + ($c7,$37,$bf,$73), ($ce,$3a,$b4,$7d), ($d5,$2d,$a9,$6f), ($dc,$20,$a2,$61), + ($76,$6d,$f6,$ad), ($7f,$60,$fd,$a3), ($64,$77,$e0,$b1), ($6d,$7a,$eb,$bf), + ($52,$59,$da,$95), ($5b,$54,$d1,$9b), ($40,$43,$cc,$89), ($49,$4e,$c7,$87), + ($3e,$05,$ae,$dd), ($37,$08,$a5,$d3), ($2c,$1f,$b8,$c1), ($25,$12,$b3,$cf), + ($1a,$31,$82,$e5), ($13,$3c,$89,$eb), ($08,$2b,$94,$f9), ($01,$26,$9f,$f7), + ($e6,$bd,$46,$4d), ($ef,$b0,$4d,$43), ($f4,$a7,$50,$51), ($fd,$aa,$5b,$5f), + ($c2,$89,$6a,$75), ($cb,$84,$61,$7b), ($d0,$93,$7c,$69), ($d9,$9e,$77,$67), + ($ae,$d5,$1e,$3d), ($a7,$d8,$15,$33), ($bc,$cf,$08,$21), ($b5,$c2,$03,$2f), + ($8a,$e1,$32,$05), ($83,$ec,$39,$0b), ($98,$fb,$24,$19), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($44,$db,$86,$78), ($5f,$cc,$9b,$6a), ($56,$c1,$90,$64), + ($69,$e2,$a1,$4e), ($60,$ef,$aa,$40), ($7b,$f8,$b7,$52), ($72,$f5,$bc,$5c), + ($05,$be,$d5,$06), ($0c,$b3,$de,$08), ($17,$a4,$c3,$1a), ($1e,$a9,$c8,$14), + ($21,$8a,$f9,$3e), ($28,$87,$f2,$30), ($33,$90,$ef,$22), ($3a,$9d,$e4,$2c), + ($dd,$06,$3d,$96), ($d4,$0b,$36,$98), ($cf,$1c,$2b,$8a), ($c6,$11,$20,$84), + ($f9,$32,$11,$ae), ($f0,$3f,$1a,$a0), ($eb,$28,$07,$b2), ($e2,$25,$0c,$bc), + ($95,$6e,$65,$e6), ($9c,$63,$6e,$e8), ($87,$74,$73,$fa), ($8e,$79,$78,$f4), + ($b1,$5a,$49,$de), ($b8,$57,$42,$d0), ($a3,$40,$5f,$c2), ($aa,$4d,$54,$cc), + ($ec,$da,$f7,$41), ($e5,$d7,$fc,$4f), ($fe,$c0,$e1,$5d), ($f7,$cd,$ea,$53), + ($c8,$ee,$db,$79), ($c1,$e3,$d0,$77), ($da,$f4,$cd,$65), ($d3,$f9,$c6,$6b), + ($a4,$b2,$af,$31), ($ad,$bf,$a4,$3f), ($b6,$a8,$b9,$2d), ($bf,$a5,$b2,$23), + ($80,$86,$83,$09), ($89,$8b,$88,$07), ($92,$9c,$95,$15), ($9b,$91,$9e,$1b), + ($7c,$0a,$47,$a1), ($75,$07,$4c,$af), ($6e,$10,$51,$bd), ($67,$1d,$5a,$b3), + ($58,$3e,$6b,$99), ($51,$33,$60,$97), ($4a,$24,$7d,$85), ($43,$29,$76,$8b), + ($34,$62,$1f,$d1), ($3d,$6f,$14,$df), ($26,$78,$09,$cd), ($2f,$75,$02,$c3), + ($10,$56,$33,$e9), ($19,$5b,$38,$e7), ($02,$4c,$25,$f5), ($0b,$41,$2e,$fb), + ($d7,$61,$8c,$9a), ($de,$6c,$87,$94), ($c5,$7b,$9a,$86), ($cc,$76,$91,$88), + ($f3,$55,$a0,$a2), ($fa,$58,$ab,$ac), ($e1,$4f,$b6,$be), ($e8,$42,$bd,$b0), + ($9f,$09,$d4,$ea), ($96,$04,$df,$e4), ($8d,$13,$c2,$f6), ($84,$1e,$c9,$f8), + ($bb,$3d,$f8,$d2), ($b2,$30,$f3,$dc), ($a9,$27,$ee,$ce), ($a0,$2a,$e5,$c0), + ($47,$b1,$3c,$7a), ($4e,$bc,$37,$74), ($55,$ab,$2a,$66), ($5c,$a6,$21,$68), + ($63,$85,$10,$42), ($6a,$88,$1b,$4c), ($71,$9f,$06,$5e), ($78,$92,$0d,$50), + ($0f,$d9,$64,$0a), ($06,$d4,$6f,$04), ($1d,$c3,$72,$16), ($14,$ce,$79,$18), + ($2b,$ed,$48,$32), ($22,$e0,$43,$3c), ($39,$f7,$5e,$2e), ($30,$fa,$55,$20), + ($9a,$b7,$01,$ec), ($93,$ba,$0a,$e2), ($88,$ad,$17,$f0), ($81,$a0,$1c,$fe), + ($be,$83,$2d,$d4), ($b7,$8e,$26,$da), ($ac,$99,$3b,$c8), ($a5,$94,$30,$c6), + ($d2,$df,$59,$9c), ($db,$d2,$52,$92), ($c0,$c5,$4f,$80), ($c9,$c8,$44,$8e), + ($f6,$eb,$75,$a4), ($ff,$e6,$7e,$aa), ($e4,$f1,$63,$b8), ($ed,$fc,$68,$b6), + ($0a,$67,$b1,$0c), ($03,$6a,$ba,$02), ($18,$7d,$a7,$10), ($11,$70,$ac,$1e), + ($2e,$53,$9d,$34), ($27,$5e,$96,$3a), ($3c,$49,$8b,$28), ($35,$44,$80,$26), + ($42,$0f,$e9,$7c), ($4b,$02,$e2,$72), ($50,$15,$ff,$60), ($59,$18,$f4,$6e), + ($66,$3b,$c5,$44), ($6f,$36,$ce,$4a), ($74,$21,$d3,$58), ($7d,$2c,$d8,$56), + ($a1,$0c,$7a,$37), ($a8,$01,$71,$39), ($b3,$16,$6c,$2b), ($ba,$1b,$67,$25), + ($85,$38,$56,$0f), ($8c,$35,$5d,$01), ($97,$22,$40,$13), ($9e,$2f,$4b,$1d), + ($e9,$64,$22,$47), ($e0,$69,$29,$49), ($fb,$7e,$34,$5b), ($f2,$73,$3f,$55), + ($cd,$50,$0e,$7f), ($c4,$5d,$05,$71), ($df,$4a,$18,$63), ($d6,$47,$13,$6d), + ($31,$dc,$ca,$d7), ($38,$d1,$c1,$d9), ($23,$c6,$dc,$cb), ($2a,$cb,$d7,$c5), + ($15,$e8,$e6,$ef), ($1c,$e5,$ed,$e1), ($07,$f2,$f0,$f3), ($0e,$ff,$fb,$fd), + ($79,$b4,$92,$a7), ($70,$b9,$99,$a9), ($6b,$ae,$84,$bb), ($62,$a3,$8f,$b5), + ($5d,$80,$be,$9f), ($54,$8d,$b5,$91), ($4f,$9a,$a8,$83), ($46,$97,$a3,$8d)); + + rcon: array[0..29] of cardinal= ( + $01, $02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, $d8, $ab, $4d, $9a, + $2f, $5e, $bc, $63, $c6, $97, $35, $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91); + +const + BCRJ = 4; + MAXROUNDSRJ= 14; + + +type + PRijndael = ^TRijndael; + TRijndael = object(TBlockCipher128) + protected + numrounds: longword; + rk, drk: array[0..MAXROUNDSRJ,0..7] of DWord; + + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + +// Serpent cipher implementation + +type + PSerpent = ^TSerpent; + TSerpent = object(TBlockCipher128) + protected + l_key: array[0..131] of dword; + + + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + +// TwoFish cipher implementation + +const + p8x8: array[0..1,0..255] of byte= (( + $a9, $67, $b3, $e8, $04, $fd, $a3, $76, + $9a, $92, $80, $78, $e4, $dd, $d1, $38, + $0d, $c6, $35, $98, $18, $f7, $ec, $6c, + $43, $75, $37, $26, $fa, $13, $94, $48, + $f2, $d0, $8b, $30, $84, $54, $df, $23, + $19, $5b, $3d, $59, $f3, $ae, $a2, $82, + $63, $01, $83, $2e, $d9, $51, $9b, $7c, + $a6, $eb, $a5, $be, $16, $0c, $e3, $61, + $c0, $8c, $3a, $f5, $73, $2c, $25, $0b, + $bb, $4e, $89, $6b, $53, $6a, $b4, $f1, + $e1, $e6, $bd, $45, $e2, $f4, $b6, $66, + $cc, $95, $03, $56, $d4, $1c, $1e, $d7, + $fb, $c3, $8e, $b5, $e9, $cf, $bf, $ba, + $ea, $77, $39, $af, $33, $c9, $62, $71, + $81, $79, $09, $ad, $24, $cd, $f9, $d8, + $e5, $c5, $b9, $4d, $44, $08, $86, $e7, + $a1, $1d, $aa, $ed, $06, $70, $b2, $d2, + $41, $7b, $a0, $11, $31, $c2, $27, $90, + $20, $f6, $60, $ff, $96, $5c, $b1, $ab, + $9e, $9c, $52, $1b, $5f, $93, $0a, $ef, + $91, $85, $49, $ee, $2d, $4f, $8f, $3b, + $47, $87, $6d, $46, $d6, $3e, $69, $64, + $2a, $ce, $cb, $2f, $fc, $97, $05, $7a, + $ac, $7f, $d5, $1a, $4b, $0e, $a7, $5a, + $28, $14, $3f, $29, $88, $3c, $4c, $02, + $b8, $da, $b0, $17, $55, $1f, $8a, $7d, + $57, $c7, $8d, $74, $b7, $c4, $9f, $72, + $7e, $15, $22, $12, $58, $07, $99, $34, + $6e, $50, $de, $68, $65, $bc, $db, $f8, + $c8, $a8, $2b, $40, $dc, $fe, $32, $a4, + $ca, $10, $21, $f0, $d3, $5d, $0f, $00, + $6f, $9d, $36, $42, $4a, $5e, $c1, $e0),( + $75, $f3, $c6, $f4, $db, $7b, $fb, $c8, + $4a, $d3, $e6, $6b, $45, $7d, $e8, $4b, + $d6, $32, $d8, $fd, $37, $71, $f1, $e1, + $30, $0f, $f8, $1b, $87, $fa, $06, $3f, + $5e, $ba, $ae, $5b, $8a, $00, $bc, $9d, + $6d, $c1, $b1, $0e, $80, $5d, $d2, $d5, + $a0, $84, $07, $14, $b5, $90, $2c, $a3, + $b2, $73, $4c, $54, $92, $74, $36, $51, + $38, $b0, $bd, $5a, $fc, $60, $62, $96, + $6c, $42, $f7, $10, $7c, $28, $27, $8c, + $13, $95, $9c, $c7, $24, $46, $3b, $70, + $ca, $e3, $85, $cb, $11, $d0, $93, $b8, + $a6, $83, $20, $ff, $9f, $77, $c3, $cc, + $03, $6f, $08, $bf, $40, $e7, $2b, $e2, + $79, $0c, $aa, $82, $41, $3a, $ea, $b9, + $e4, $9a, $a4, $97, $7e, $da, $7a, $17, + $66, $94, $a1, $1d, $3d, $f0, $de, $b3, + $0b, $72, $a7, $1c, $ef, $d1, $53, $3e, + $8f, $33, $26, $5f, $ec, $76, $2a, $49, + $81, $88, $ee, $21, $c4, $1a, $eb, $d9, + $c5, $39, $99, $cd, $ad, $31, $8b, $01, + $18, $23, $dd, $1f, $4e, $2d, $f9, $48, + $4f, $f2, $65, $8e, $78, $5c, $58, $19, + $8d, $e5, $98, $57, $67, $7f, $05, $64, + $af, $63, $b6, $fe, $f5, $b7, $3c, $a5, + $ce, $e9, $68, $44, $e0, $4d, $43, $69, + $29, $2e, $ac, $15, $59, $a8, $0a, $9e, + $6e, $47, $df, $34, $35, $6a, $cf, $dc, + $22, $c9, $c0, $9b, $89, $d4, $ed, $ab, + $12, $a2, $0d, $52, $bb, $02, $2f, $a9, + $d7, $61, $1e, $b4, $50, $04, $f6, $c2, + $16, $25, $86, $56, $55, $09, $be, $91)); + +const + INPUTWHITEN= 0; + OUTPUTWHITEN= 4; + NUMROUNDSTF= 16; + ROUNDSUBKEYS= (OUTPUTWHITEN + 4); + TOTALSUBKEYS= (ROUNDSUBKEYS + NUMROUNDSTF * 2); + RS_GF_FDBK= $14d; + MDS_GF_FDBK= $169; + SK_STEP= $02020202; + SK_BUMP= $01010101; + SK_ROTL= 9; + +type + PTwoFish = ^TTwoFish; + TTwoFish = object(TBlockCipher128) + protected + SubKeys: array[0..TOTALSUBKEYS-1] of DWord; + sbox: array[0..3,0..255] of DWord; + + public + procedure InitKey(const Key; Size: longword); virtual; + procedure Burn; virtual; + procedure EncryptECB(const InData; var OutData); virtual; + procedure DecryptECB(const InData; var OutData); virtual; + + destructor Destroy; virtual; + end; + +type + PRC4 = ^TRC4; + + TRC4 = object (TObj) + protected + KeyData, KeyOrg: array[0..255] of byte; + public + procedure InitKey(const Key; Size: longword; InitVector: pointer); + procedure Reset; + procedure Burn; + procedure Encrypt(const InData; var OutData; Size: longword); + procedure Decrypt(const InData; var OutData; Size: longword); + destructor Destroy; virtual; + end; + + + TKOLRijndael = PRijndael; + TKOLMars = PMars; + TKOLICE = PICE; + TKOLICE2 = PICE2; + TKOLThinICE = PThinICE; + TKOLDES = PDES; + TKOL3DES = P3DES; + TKOLTEA = PTEA; + TKOLRC2 = PRC2; + TKOLRC4 = PRC4; + TKOLRC5 = PRC5; + TKOLRC6 = PRC6; + TKOLMisty1 = PMisty1; + TKOLIDEA = PIDEA; + TKOLGOST = PGOST; + TKOLCast128 = PCast128; + TKOLCast256 = PCast256; + TKOLBlowfish = PBlowfish; + TKOLTwofish = PTwofish; + TKOLSerpent = PSerpent; + + + + +// TKOLBlockCipher64 = PBlockCipher64; +// TKOLBlockCipher128 = PBlockCipher128; +function NewSerpent: PSerpent; +function NewRijndael: PRijndael; +function NewICE: PICE; +function NewICE2: PICE2; +function NewThinICE: PThinICE; +function New3DES: P3DES; +function NewDES: PDES; +function NewTEA: PTEA; +function NewRC2: PRC2; +function NewRC4: PRC4; +function NewRC5: PRC5; +function NewRC6: PRC6; +function NewMisty1: PMisty1; +function NewIDEA: PIDEA; +function NewGOST: PGOST; +function NewCast256: PCast256; +function NewCast128: PCast128; +function NewBlowfish: PBlowfish; +function NewTwofish: PTwofish; +function NewMars: PMars; + +//function NewBlockCipher64: PBlockCipher64; +//function NewBlockCipher128: PBlockCipher128; + + +implementation + +// uses CommCtrl, ShellApi; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TBlockCipher64.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +//function NewBlockCipher64; +//begin +//New(Result, Create); + +// code +//end; +//////////////////////////////////////////////////////////////////////////////// + +destructor TBlockCipher128.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +//function NewBlockCipher128; +//begin +//New(Result, Create); + +// code +//end; +//////////////////////////////////////////////////////////////////////////////// +procedure XorBlock(var InData1, InData2; Size: longword); +var + i: longword; +begin + for i:= 1 to Size do + Pbyte(longword(@InData1)+i-1)^:= Pbyte(longword(@InData1)+i-1)^ xor Pbyte(longword(@InData2)+i-1)^; +end; + + +procedure TBlockCipher64.EncryptECB(const Indata; var Outdata); +begin +end; + +procedure TBlockCipher64.DecryptECB(const Indata; var Outdata); +begin +end; + +procedure TBlockCipher64.InitKey(const Key; Size: longword); +begin +end; + + +procedure TBlockCipher128.EncryptECB(const Indata; var Outdata); +begin +end; + +procedure TBlockCipher128.DecryptECB(const Indata; var Outdata); +begin +end; + +procedure TBlockCipher128.InitKey(const Key; Size: longword); +begin +end; + +procedure TBlockCipher64.IncCounter; +var + i: integer; +begin + Inc(CV[7]); + i:= 7; + while (i> 0) and (CV[i] = 0) do + begin + Inc(CV[i-1]); + Dec(i); + end; +end; + +procedure TBlockCipher64.InitBlockCipher64(const Key; Size: longword; InitVector: pointer); +begin + {inherited} + //Init(Key,Size,InitVector); + InitKey(Key,Size); + if InitVector= nil then + begin + FillChar(IV,8,0); + EncryptECB(IV,IV); + Reset; + end + else + begin + Move(InitVector^,IV,8); + Reset; + end; +end; + +procedure TBlockCipher64.SetIV(const Value); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Move(Value,IV,8); + Reset; +end; + +procedure TBlockCipher64.GetIV(var Value); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Move(CV,Value,8); +end; + +procedure TBlockCipher64.Reset; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized') +// else + Move(IV,CV,8); +end; + +procedure TBlockCipher64.Burn; +begin + FillChar(IV,8,$FF); + FillChar(CV,8,$FF); +// inherited Burn; +end; + +procedure TBlockCipher64.EncryptCBC(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + Move(p1^,p2^,8); + XorBlock(p2^,CV,8); + EncryptECB(p2^,p2^); + Move(p2^,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.DecryptCBC(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; + Temp: array[0..7] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + Move(p1^,p2^,8); + Move(p1^,Temp,8); + DecryptECB(p2^,p2^); + XorBlock(p2^,CV,8); + Move(Temp,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.EncryptCFB8bit(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + Temp: array[0..7] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to Size do + begin + EncryptECB(CV,Temp); + p2^:= p1^ xor Temp[0]; + Move(CV[1],CV[0],8-1); + CV[7]:= p2^; + Inc(p1); + Inc(p2); + end; +end; + +procedure TBlockCipher64.DecryptCFB8bit(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + TempByte: byte; + Temp: array[0..7] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to Size do + begin + TempByte:= p1^; + EncryptECB(CV,Temp); + p2^:= p1^ xor Temp[0]; + Move(CV[1],CV[0],8-1); + CV[7]:= TempByte; + Inc(p1); + Inc(p2); + end; +end; + +procedure TBlockCipher64.EncryptCFBblock(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,8); + XorBlock(p2^,CV,8); + Move(p2^,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.DecryptCFBblock(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + Temp: array[0..7] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + Move(p1^,Temp,8); + EncryptECB(CV,CV); + Move(p1^,p2^,8); + XorBlock(p2^,CV,8); + Move(Temp,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.EncryptOFB(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,8); + XorBlock(p2^,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.DecryptOFB(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,8); + XorBlock(p2^,CV,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,CV,Size mod 8); + end; +end; + +procedure TBlockCipher64.EncryptCTR(const Indata; var Outdata; Size: longword); +var + temp: array[0..7] of byte; + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,8); + XorBlock(p2^,temp,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,temp,Size mod 8); + end; +end; + +procedure TBlockCipher64.DecryptCTR(const Indata; var Outdata; Size: longword); +var + temp: array[0..7] of byte; + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 8) do + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,8); + XorBlock(p2^,temp,8); + p1:= pointer(longword(p1) + 8); + p2:= pointer(longword(p2) + 8); + end; + if (Size mod 8)<> 0 then + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,Size mod 8); + XorBlock(p2^,temp,Size mod 8); + end; +end; + +{** TBlockCipher128 ********************************************************} + +procedure TBlockCipher128.IncCounter; +var + i: integer; +begin + Inc(CV[15]); + i:= 15; + while (i> 0) and (CV[i] = 0) do + begin + Inc(CV[i-1]); + Dec(i); + end; +end; + +procedure TBlockCipher128.InitBlockCipher128(const Key; Size: longword; InitVector: pointer); +begin +// inherited Init(Key,Size,InitVector); + InitKey(Key,Size); + if InitVector= nil then + begin + FillChar(IV,16,0); + EncryptECB(IV,IV); + Reset; + end + else + begin + Move(InitVector^,IV,16); + Reset; + end; +end; + +procedure TBlockCipher128.SetIV(const Value); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Move(Value,IV,16); + Reset; +end; + +procedure TBlockCipher128.GetIV(var Value); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Move(CV,Value,16); +end; + +procedure TBlockCipher128.Reset; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized') +// else + Move(IV,CV,16); +end; + +procedure TBlockCipher128.Burn; +begin + FillChar(IV,16,$FF); + FillChar(CV,16,$FF); +// inherited Burn; +end; + +procedure TBlockCipher128.EncryptCBC(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + Move(p1^,p2^,16); + XorBlock(p2^,CV,16); + EncryptECB(p2^,p2^); + Move(p2^,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.DecryptCBC(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; + Temp: array[0..15] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + Move(p1^,p2^,16); + Move(p1^,Temp,16); + DecryptECB(p2^,p2^); + XorBlock(p2^,CV,16); + Move(Temp,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.EncryptCFB8bit(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + Temp: array[0..15] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to Size do + begin + EncryptECB(CV,Temp); + p2^:= p1^ xor Temp[0]; + Move(CV[1],CV[0],15); + CV[15]:= p2^; + Inc(p1); + Inc(p2); + end; +end; + +procedure TBlockCipher128.DecryptCFB8bit(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + TempByte: byte; + Temp: array[0..15] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to Size do + begin + TempByte:= p1^; + EncryptECB(CV,Temp); + p2^:= p1^ xor Temp[0]; + Move(CV[1],CV[0],15); + CV[15]:= TempByte; + Inc(p1); + Inc(p2); + end; +end; + +procedure TBlockCipher128.EncryptCFBblock(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,16); + XorBlock(p2^,CV,16); + Move(p2^,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.DecryptCFBblock(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: Pbyte; + Temp: array[0..15] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + Move(p1^,Temp,16); + EncryptECB(CV,CV); + Move(p1^,p2^,16); + XorBlock(p2^,CV,16); + Move(Temp,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.EncryptOFB(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,16); + XorBlock(p2^,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.DecryptOFB(const Indata; var Outdata; Size: longword); +var + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + EncryptECB(CV,CV); + Move(p1^,p2^,16); + XorBlock(p2^,CV,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,CV); + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,CV,Size mod 16); + end; +end; + +procedure TBlockCipher128.EncryptCTR(const Indata; var Outdata; Size: longword); +var + temp: array[0..15] of byte; + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,16); + XorBlock(p2^,temp,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,temp,Size mod 16); + end; +end; + +procedure TBlockCipher128.DecryptCTR(const Indata; var Outdata; Size: longword); +var + temp: array[0..15] of byte; + i: longword; + p1, p2: pointer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + p1:= @Indata; + p2:= @Outdata; + for i:= 1 to (Size div 16) do + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,16); + XorBlock(p2^,temp,16); + p1:= pointer(longword(p1) + 16); + p2:= pointer(longword(p2) + 16); + end; + if (Size mod 16)<> 0 then + begin + EncryptECB(CV,temp); + IncCounter; + Move(p1^,p2^,Size mod 16); + XorBlock(p2^,temp,Size mod 16); + end; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TBlowfish.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewBlowfish; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +{$R-}{$Q-} +//{$I DCPblowfish.inc} + +procedure TBlowfish.InitKey(const Key; Size: longword); +var + i, k: longword; + A: DWord; + KeyB: PByteArray; + Block: array[0..7] of byte; +begin +burn; + Size:= Size div 8; + KeyB:= @Key; + Move(SBoxOrg,SBox,Sizeof(SBox)); + Move(PBoxOrg,PBox,Sizeof(PBox)); + k:= 0; + for i:= 0 to 17 do + begin + A:= dword(KeyB^[(k+3) mod Size]); + A:= A + (dword(KeyB^[(k+2) mod Size]) shl 8); + A:= A + (dword(KeyB^[(k+1) mod Size]) shl 16); + A:= A + (dword(KeyB^[k]) shl 24); + PBox[i]:= PBox[i] xor A; + k:= (k+4) mod Size; + end; + FillChar(Block,Sizeof(Block),0); + for i:= 0 to 8 do + begin + EncryptECB(Block,Block); + PBox[i*2]:= dword(Block[3]) + (dword(Block[2]) shl 8) + (dword(Block[1]) shl 16) + (dword(Block[0]) shl 24); + PBox[i*2+1]:= dword(Block[7]) + (dword(Block[6]) shl 8) + (dword(Block[5]) shl 16) + (dword(Block[4]) shl 24); + end; + for k:= 0 to 3 do + begin + for i:= 0 to 127 do + begin + EncryptECB(Block,Block); + SBox[k,i*2]:= dword(Block[3]) + (dword(Block[2]) shl 8) + (dword(Block[1]) shl 16) + (dword(Block[0]) shl 24); + SBox[k,i*2+1]:= dword(Block[7]) + (dword(Block[6]) shl 8) + (dword(Block[5]) shl 16) + (dword(Block[4]) shl 24); + end; + end; +end; + +procedure TBlowfish.Burn; +begin + FillChar(SBox,Sizeof(SBox),$FF); + FillChar(PBox,Sizeof(PBox),$FF); + inherited Burn; +end; + +procedure TBlowfish.EncryptECB(const InData; var OutData); +var + xL, xR: DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + xL:= Pdword(@InData)^; + xR:= Pdword(longword(@InData)+4)^; + xL:= ((xL and $FF) shl 24) or ((xL and $FF00) shl 8) or ((xL and $FF0000) shr 8) or ((xL and $FF000000) shr 24); + xR:= ((xR and $FF) shl 24) or ((xR and $FF00) shl 8) or ((xR and $FF0000) shr 8) or ((xR and $FF000000) shr 24); + xL:= xL xor PBox[0]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[1]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[2]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[3]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[4]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[5]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[6]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[7]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[8]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[9]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[10]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[11]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[12]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[13]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[14]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[15]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[16]; + xR:= xR xor PBox[17]; + xL:= ((xL and $FF) shl 24) or ((xL and $FF00) shl 8) or ((xL and $FF0000) shr 8) or ((xL and $FF000000) shr 24); + xR:= ((xR and $FF) shl 24) or ((xR and $FF00) shl 8) or ((xR and $FF0000) shr 8) or ((xR and $FF000000) shr 24); + Pdword(@OutData)^:= xR; + Pdword(longword(@OutData)+4)^:= xL; +end; + +procedure TBlowfish.DecryptECB(const InData; var OutData); +var + xL, xR: DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + xL:= Pdword(@InData)^; + xR:= Pdword(longword(@InData)+4)^; + xL:= (xL shr 24) or ((xL shr 8) and $FF00) or ((xL shl 8) and $FF0000) or (xL shl 24); + xR:= (xR shr 24) or ((xR shr 8) and $FF00) or ((xR shl 8) and $FF0000) or (xR shl 24); + xL:= xL xor PBox[17]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[16]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[15]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[14]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[13]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[12]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[11]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[10]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[9]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[8]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[7]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[6]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[5]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[4]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[3]; + xR:= xR xor (((SBox[0,(xL shr 24) and $FF] + SBox[1,(xL shr 16) and $FF]) xor + SBox[2,(xL shr 8) and $FF]) + SBox[3,xL and $FF]) xor PBox[2]; + xL:= xL xor (((SBox[0,(xR shr 24) and $FF] + SBox[1,(xR shr 16) and $FF]) xor + SBox[2,(xR shr 8) and $FF]) + SBox[3,xR and $FF]) xor PBox[1]; + xR:= xR xor PBox[0]; + xL:= (xL shr 24) or ((xL shr 8) and $FF00) or ((xL shl 8) and $FF0000) or (xL shl 24); + xR:= (xR shr 24) or ((xR shr 8) and $FF00) or ((xR shl 8) and $FF0000) or (xR shl 24); + Pdword(@OutData)^:= xR; + Pdword(longword(@OutData)+4)^:= xL; +end; + +{$R-}{$Q-} + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TCast128.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewCast128; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +function LRot32(a, n: dword): dword; +begin + Result:= (a shl n) or (a shr (32-n)); +end; + + +procedure TCast128.InitKey(const Key; Size: longword); +var + x, t, z: array[0..3] of DWord; + i: longword; +begin +burn; + Size:= Size div 8; + if Size<= 10 then + Rounds:= 12 + else + Rounds:= 16; + FillChar(x,Sizeof(x),0); + Move(Key,x,Size); + x[0]:= (x[0] shr 24) or ((x[0] shr 8) and $FF00) or ((x[0] shl 8) and $FF0000) or (x[0] shl 24); + x[1]:= (x[1] shr 24) or ((x[1] shr 8) and $FF00) or ((x[1] shl 8) and $FF0000) or (x[1] shl 24); + x[2]:= (x[2] shr 24) or ((x[2] shr 8) and $FF00) or ((x[2] shl 8) and $FF0000) or (x[2] shl 24); + x[3]:= (x[3] shr 24) or ((x[3] shr 8) and $FF00) or ((x[3] shl 8) and $FF0000) or (x[3] shl 24); + i:= 0; + while i< 32 do + begin + case (i and 4) of + 0: + begin + z[0]:= x[0] xor cast_sbox5[(x[3] shr 16) and $FF] xor + cast_sbox6[x[3] and $FF] xor cast_sbox7[x[3] shr 24] xor + cast_sbox8[(x[3] shr 8) and $FF] xor cast_sbox7[x[2] shr 24]; + t[0]:= z[0]; + z[1]:= x[2] xor cast_sbox5[z[0] shr 24] xor + cast_sbox6[(z[0] shr 8) and $FF] xor cast_sbox7[(z[0] shr 16) and $FF] xor + cast_sbox8[z[0] and $FF] xor cast_sbox8[(x[2] shr 8) and $FF]; + t[1]:= z[1]; + z[2]:= x[3] xor cast_sbox5[z[1] and $FF] xor + cast_sbox6[(z[1] shr 8) and $FF] xor cast_sbox7[(z[1] shr 16) and $FF] xor + cast_sbox8[z[1] shr 24] xor cast_sbox5[(x[2] shr 16) and $FF]; + t[2]:= z[2]; + z[3]:= x[1] xor cast_sbox5[(z[2] shr 8) and $FF] xor + cast_sbox6[(z[2] shr 16) and $FF] xor cast_sbox7[z[2] and $FF] xor + cast_sbox8[z[2] shr 24] xor cast_sbox6[x[2] and $FF]; + t[3]:= z[3]; + end; + 4: + begin + x[0]:= z[2] xor cast_sbox5[(z[1] shr 16) and $FF] xor + cast_sbox6[z[1] and $FF] xor cast_sbox7[z[1] shr 24] xor + cast_sbox8[(z[1] shr 8) and $FF] xor cast_sbox7[z[0] shr 24]; + t[0]:= x[0]; + x[1]:= z[0] xor cast_sbox5[x[0] shr 24] xor + cast_sbox6[(x[0] shr 8) and $FF] xor cast_sbox7[(x[0] shr 16) and $FF] xor + cast_sbox8[x[0] and $FF] xor cast_sbox8[(z[0] shr 8) and $FF]; + t[1]:= x[1]; + x[2]:= z[1] xor cast_sbox5[x[1] and $FF] xor + cast_sbox6[(x[1] shr 8) and $FF] xor cast_sbox7[(x[1] shr 16) and $FF] xor + cast_sbox8[x[1] shr 24] xor cast_sbox5[(z[0] shr 16) and $FF]; + t[2]:= x[2]; + x[3]:= z[3] xor cast_sbox5[(x[2] shr 8) and $FF] xor + cast_sbox6[(x[2] shr 16) and $FF] xor cast_sbox7[x[2] and $FF] xor + cast_sbox8[x[2] shr 24] xor cast_sbox6[z[0] and $FF]; + t[3]:= x[3]; + end; + end; + case (i and 12) of + 0,12: + begin + KeyData[i+0]:= cast_sbox5[t[2] shr 24] xor cast_sbox6[(t[2] shr 16) and $FF] xor + cast_sbox7[t[1] and $FF] xor cast_sbox8[(t[1] shr 8) and $FF]; + KeyData[i+1]:= cast_sbox5[(t[2] shr 8) and $FF] xor cast_sbox6[t[2] and $FF] xor + cast_sbox7[(t[1] shr 16) and $FF] xor cast_sbox8[t[1] shr 24]; + KeyData[i+2]:= cast_sbox5[t[3] shr 24] xor cast_sbox6[(t[3] shr 16) and $FF] xor + cast_sbox7[t[0] and $FF] xor cast_sbox8[(t[0] shr 8) and $FF]; + KeyData[i+3]:= cast_sbox5[(t[3] shr 8) and $FF] xor cast_sbox6[t[3] and $FF] xor + cast_sbox7[(t[0] shr 16) and $FF] xor cast_sbox8[t[0] shr 24]; + end; + 4,8: + begin + KeyData[i+0]:= cast_sbox5[t[0] and $FF] xor cast_sbox6[(t[0] shr 8) and $FF] xor + cast_sbox7[t[3] shr 24] xor cast_sbox8[(t[3] shr 16) and $FF]; + KeyData[i+1]:= cast_sbox5[(t[0] shr 16) and $FF] xor cast_sbox6[t[0] shr 24] xor + cast_sbox7[(t[3] shr 8) and $FF] xor cast_sbox8[t[3] and $FF]; + KeyData[i+2]:= cast_sbox5[t[1] and $FF] xor cast_sbox6[(t[1] shr 8) and $FF] xor + cast_sbox7[t[2] shr 24] xor cast_sbox8[(t[2] shr 16) and $FF]; + KeyData[i+3]:= cast_sbox5[(t[1] shr 16) and $FF] xor cast_sbox6[t[1] shr 24] xor + cast_sbox7[(t[2] shr 8) and $FF] xor cast_sbox8[t[2] and $FF]; + end; + end; + case (i and 12) of + 0: + begin + KeyData[i+0]:= KeyData[i+0] xor cast_sbox5[(z[0] shr 8) and $FF]; + KeyData[i+1]:= KeyData[i+1] xor cast_sbox6[(z[1] shr 8) and $FF]; + KeyData[i+2]:= KeyData[i+2] xor cast_sbox7[(z[2] shr 16) and $FF]; + KeyData[i+3]:= KeyData[i+3] xor cast_sbox8[z[3] shr 24]; + end; + 4: + begin + KeyData[i+0]:= KeyData[i+0] xor cast_sbox5[x[2] shr 24]; + KeyData[i+1]:= KeyData[i+1] xor cast_sbox6[(x[3] shr 16) and $FF]; + KeyData[i+2]:= KeyData[i+2] xor cast_sbox7[x[0] and $FF]; + KeyData[i+3]:= KeyData[i+3] xor cast_sbox8[x[1] and $FF]; + end; + 8: + begin + KeyData[i+0]:= KeyData[i+0] xor cast_sbox5[(z[2] shr 16) and $FF]; + KeyData[i+1]:= KeyData[i+1] xor cast_sbox6[z[3] shr 24]; + KeyData[i+2]:= KeyData[i+2] xor cast_sbox7[(z[0] shr 8) and $FF]; + KeyData[i+3]:= KeyData[i+3] xor cast_sbox8[(z[1] shr 8) and $FF]; + end; + 12: + begin + KeyData[i+0]:= KeyData[i+0] xor cast_sbox5[x[0] and $FF]; + KeyData[i+1]:= KeyData[i+1] xor cast_sbox6[x[1] and $FF]; + KeyData[i+2]:= KeyData[i+2] xor cast_sbox7[x[2] shr 24]; + KeyData[i+3]:= KeyData[i+3] xor cast_sbox8[(x[3] shr 16) and $FF]; + end; + end; + if (i >= 16) then + begin + KeyData[i+0]:= KeyData[i+0] and 31; + KeyData[i+1]:= KeyData[i+1] and 31; + KeyData[i+2]:= KeyData[i+2] and 31; + KeyData[i+3]:= KeyData[i+3] and 31; + end; + Inc(i,4); + end; +end; + +procedure TCast128.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),$FF); + Rounds:= 0; + inherited Burn; +end; + +procedure TCast128.EncryptECB(const InData; var OutData); +var + t, l, r: DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + l:= Pdword(@InData)^; + r:= Pdword(longword(@InData)+4)^; + l:= (l shr 24) or ((l shr 8) and $FF00) or ((l shl 8) and $FF0000) or (l shl 24); + r:= (r shr 24) or ((r shr 8) and $FF00) or ((r shl 8) and $FF0000) or (r shl 24); + t:= LRot32(KeyData[0]+r, KeyData[0+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[1] xor l, KeyData[1+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[2]-r, KeyData[2+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[3]+l, KeyData[3+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[4] xor r, KeyData[4+16]); + l:= l xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[5]-l, KeyData[5+16]); + r:= r xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[6]+r, KeyData[6+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[7] xor l, KeyData[7+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[8]-r, KeyData[8+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[9]+l, KeyData[9+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[10] xor r, KeyData[10+16]); + l:= l xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[11]-l, KeyData[11+16]); + r:= r xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + if Rounds> 12 then + begin + t:= LRot32(KeyData[12]+r, KeyData[12+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[13] xor l, KeyData[13+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[14]-r, KeyData[14+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[15]+l, KeyData[15+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + end; + l:= (l shr 24) or ((l shr 8) and $FF00) or ((l shl 8) and $FF0000) or (l shl 24); + r:= (r shr 24) or ((r shr 8) and $FF00) or ((r shl 8) and $FF0000) or (r shl 24); + Pdword(@OutData)^:= r; + Pdword(longword(@OutData)+4)^:= l; +end; + +procedure TCast128.DecryptECB(const InData; var OutData); +var + t, l, r: DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + r:= Pdword(@InData)^; + l:= Pdword(longword(@InData)+4)^; + l:= (l shr 24) or ((l shr 8) and $FF00) or ((l shl 8) and $FF0000) or (l shl 24); + r:= (r shr 24) or ((r shr 8) and $FF00) or ((r shl 8) and $FF0000) or (r shl 24); + if Rounds> 12 then + begin + t:= LRot32(KeyData[15]+l, KeyData[15+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[14]-r, KeyData[14+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[13] xor l, KeyData[13+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[12]+r, KeyData[12+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + end; + t:= LRot32(KeyData[11]-l, KeyData[11+16]); + r:= r xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[10] xor r, KeyData[10+16]); + l:= l xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[9]+l, KeyData[9+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[8]-r, KeyData[8+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[7] xor l, KeyData[7+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[6]+r, KeyData[6+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[5]-l, KeyData[5+16]); + r:= r xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[4] xor r, KeyData[4+16]); + l:= l xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[3]+l, KeyData[3+16]); + r:= r xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + t:= LRot32(KeyData[2]-r, KeyData[2+16]); + l:= l xor (((cast_sbox1[t shr 24] + cast_sbox2[(t shr 16) and $FF]) xor + cast_sbox3[(t shr 8) and $FF]) - cast_sbox4[t and $FF]); + t:= LRot32(KeyData[1] xor l, KeyData[1+16]); + r:= r xor (((cast_sbox1[t shr 24] - cast_sbox2[(t shr 16) and $FF]) + + cast_sbox3[(t shr 8) and $FF]) xor cast_sbox4[t and $FF]); + t:= LRot32(KeyData[0]+r, KeyData[0+16]); + l:= l xor (((cast_sbox1[t shr 24] xor cast_sbox2[(t shr 16) and $FF]) - + cast_sbox3[(t shr 8) and $FF]) + cast_sbox4[t and $FF]); + l:= (l shr 24) or ((l shr 8) and $FF00) or ((l shl 8) and $FF0000) or (l shl 24); + r:= (r shr 24) or ((r shr 8) and $FF00) or ((r shl 8) and $FF0000) or (r shl 24); + Pdword(@OutData)^:= l; + Pdword(longword(@OutData)+4)^:= r; +end; + +destructor TGOST.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewGOST; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// +{$R-}{$Q-} +//{$I DCPgost.inc} + + +procedure TGOST.InitKey(const Key; Size: longword); +var + i: longword; + userkey: array[0..31] of byte; +begin +burn; + + Size:= Size div 8; + + FillChar(userkey,Sizeof(userkey),0); + Move(Key,userkey,Size); + for i:= 0 to 7 do + KeyData[i]:= (dword(UserKey[4*i+3]) shl 24) or (dword(UserKey[4*i+2]) shl 16) or + (dword(UserKey[4*i+1]) shl 8) or (dword(UserKey[4*i+0])); +end; + +procedure TGOST.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure TGOST.EncryptECB(const InData; var OutData); +var + n1, n2: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + n1:= PDword(@InData)^; + n2:= PDword(dword(@InData)+4)^; + for i:= 0 to 2 do + begin + n2:= n2 xor (sTable[3,(n1+KeyData[0]) shr 24] xor sTable[2,((n1+KeyData[0]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[0]) shr 8) and $FF] xor sTable[0,(n1+KeyData[0]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[1]) shr 24] xor sTable[2,((n2+KeyData[1]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[1]) shr 8) and $FF] xor sTable[0,(n2+KeyData[1]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[2]) shr 24] xor sTable[2,((n1+KeyData[2]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[2]) shr 8) and $FF] xor sTable[0,(n1+KeyData[2]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[3]) shr 24] xor sTable[2,((n2+KeyData[3]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[3]) shr 8) and $FF] xor sTable[0,(n2+KeyData[3]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[4]) shr 24] xor sTable[2,((n1+KeyData[4]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[4]) shr 8) and $FF] xor sTable[0,(n1+KeyData[4]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[5]) shr 24] xor sTable[2,((n2+KeyData[5]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[5]) shr 8) and $FF] xor sTable[0,(n2+KeyData[5]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[6]) shr 24] xor sTable[2,((n1+KeyData[6]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[6]) shr 8) and $FF] xor sTable[0,(n1+KeyData[6]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[7]) shr 24] xor sTable[2,((n2+KeyData[7]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[7]) shr 8) and $FF] xor sTable[0,(n2+KeyData[7]) and $FF]); + end; + n2:= n2 xor (sTable[3,(n1+KeyData[7]) shr 24] xor sTable[2,((n1+KeyData[7]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[7]) shr 8) and $FF] xor sTable[0,(n1+KeyData[7]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[6]) shr 24] xor sTable[2,((n2+KeyData[6]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[6]) shr 8) and $FF] xor sTable[0,(n2+KeyData[6]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[5]) shr 24] xor sTable[2,((n1+KeyData[5]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[5]) shr 8) and $FF] xor sTable[0,(n1+KeyData[5]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[4]) shr 24] xor sTable[2,((n2+KeyData[4]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[4]) shr 8) and $FF] xor sTable[0,(n2+KeyData[4]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[3]) shr 24] xor sTable[2,((n1+KeyData[3]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[3]) shr 8) and $FF] xor sTable[0,(n1+KeyData[3]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[2]) shr 24] xor sTable[2,((n2+KeyData[2]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[2]) shr 8) and $FF] xor sTable[0,(n2+KeyData[2]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[1]) shr 24] xor sTable[2,((n1+KeyData[1]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[1]) shr 8) and $FF] xor sTable[0,(n1+KeyData[1]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[0]) shr 24] xor sTable[2,((n2+KeyData[0]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[0]) shr 8) and $FF] xor sTable[0,(n2+KeyData[0]) and $FF]); + PDword(@OutData)^:= n2; + PDword(dword(@OutData)+4)^:= n1; +end; + +procedure TGOST.DecryptECB(const InData; var OutData); +var + n1, n2: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + n1:= PDword(@InData)^; + n2:= PDword(dword(@InData)+4)^; + n2:= n2 xor (sTable[3,(n1+KeyData[0]) shr 24] xor sTable[2,((n1+KeyData[0]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[0]) shr 8) and $FF] xor sTable[0,(n1+KeyData[0]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[1]) shr 24] xor sTable[2,((n2+KeyData[1]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[1]) shr 8) and $FF] xor sTable[0,(n2+KeyData[1]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[2]) shr 24] xor sTable[2,((n1+KeyData[2]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[2]) shr 8) and $FF] xor sTable[0,(n1+KeyData[2]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[3]) shr 24] xor sTable[2,((n2+KeyData[3]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[3]) shr 8) and $FF] xor sTable[0,(n2+KeyData[3]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[4]) shr 24] xor sTable[2,((n1+KeyData[4]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[4]) shr 8) and $FF] xor sTable[0,(n1+KeyData[4]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[5]) shr 24] xor sTable[2,((n2+KeyData[5]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[5]) shr 8) and $FF] xor sTable[0,(n2+KeyData[5]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[6]) shr 24] xor sTable[2,((n1+KeyData[6]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[6]) shr 8) and $FF] xor sTable[0,(n1+KeyData[6]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[7]) shr 24] xor sTable[2,((n2+KeyData[7]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[7]) shr 8) and $FF] xor sTable[0,(n2+KeyData[7]) and $FF]); + for i:= 0 to 2 do + begin + n2:= n2 xor (sTable[3,(n1+KeyData[7]) shr 24] xor sTable[2,((n1+KeyData[7]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[7]) shr 8) and $FF] xor sTable[0,(n1+KeyData[7]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[6]) shr 24] xor sTable[2,((n2+KeyData[6]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[6]) shr 8) and $FF] xor sTable[0,(n2+KeyData[6]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[5]) shr 24] xor sTable[2,((n1+KeyData[5]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[5]) shr 8) and $FF] xor sTable[0,(n1+KeyData[5]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[4]) shr 24] xor sTable[2,((n2+KeyData[4]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[4]) shr 8) and $FF] xor sTable[0,(n2+KeyData[4]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[3]) shr 24] xor sTable[2,((n1+KeyData[3]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[3]) shr 8) and $FF] xor sTable[0,(n1+KeyData[3]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[2]) shr 24] xor sTable[2,((n2+KeyData[2]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[2]) shr 8) and $FF] xor sTable[0,(n2+KeyData[2]) and $FF]); + n2:= n2 xor (sTable[3,(n1+KeyData[1]) shr 24] xor sTable[2,((n1+KeyData[1]) shr 16) and $FF] + xor sTable[1,((n1+KeyData[1]) shr 8) and $FF] xor sTable[0,(n1+KeyData[1]) and $FF]); + n1:= n1 xor (sTable[3,(n2+KeyData[0]) shr 24] xor sTable[2,((n2+KeyData[0]) shr 16) and $FF] + xor sTable[1,((n2+KeyData[0]) shr 8) and $FF] xor sTable[0,(n2+KeyData[0]) and $FF]); + end; + PDword(@OutData)^:= n2; + PDword(dword(@OutData)+4)^:= n1; +end; + +destructor TIDEA.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewIDEA; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +{$R-}{$Q-} + + +function MulInv(x: word): word; +var + t0, t1, q, y: word; +begin + if x<= 1 then + begin + Result:= x; + Exit; + end; + t1:= DWord($10001) div x; + y:= DWord($10001) mod x; + if y= 1 then + begin + Result:= (1 - t1) and $FFFF; + Exit; + end; + t0:= 1; + repeat + q:= x div y; + x:= x mod y; + t0:= t0 + (q*t1); + if x= 1 then + begin + Result:= t0; + Exit; + end; + q:= y div x; + y:= y mod x; + t1:= t1 + (q*t0); + until y= 1; + Result:= (1-t1) and $FFFF; +end; + +procedure TIDEA.InitKey(const Key; Size: longword); +var + i: integer; +begin +burn; + Size:= Size div 8; + + FillChar(EK,Sizeof(EK),0); + Move(Key,EK,Size); + for i:= 0 to 7 do + EK[i]:= (EK[i] shl 8) or (EK[i] shr 8); + for i:= 1 to 5 do + begin + EK[(i*8)+0]:= (EK[((i-1)*8)+1] shl 9) or (EK[((i-1)*8)+2] shr 7); + EK[(i*8)+1]:= (EK[((i-1)*8)+2] shl 9) or (EK[((i-1)*8)+3] shr 7); + EK[(i*8)+2]:= (EK[((i-1)*8)+3] shl 9) or (EK[((i-1)*8)+4] shr 7); + EK[(i*8)+3]:= (EK[((i-1)*8)+4] shl 9) or (EK[((i-1)*8)+5] shr 7); + EK[(i*8)+4]:= (EK[((i-1)*8)+5] shl 9) or (EK[((i-1)*8)+6] shr 7); + EK[(i*8)+5]:= (EK[((i-1)*8)+6] shl 9) or (EK[((i-1)*8)+7] shr 7); + EK[(i*8)+6]:= (EK[((i-1)*8)+7] shl 9) or (EK[((i-1)*8)+0] shr 7); + EK[(i*8)+7]:= (EK[((i-1)*8)+0] shl 9) or (EK[((i-1)*8)+1] shr 7); + end; + EK[48]:= (EK[41] shl 9) or (EK[42] shr 7); + EK[49]:= (EK[42] shl 9) or (EK[43] shr 7); + EK[50]:= (EK[43] shl 9) or (EK[44] shr 7); + EK[51]:= (EK[44] shl 9) or (EK[45] shr 7); + + DK[51]:= MulInv(EK[3]); + DK[50]:= -EK[2]; + DK[49]:= -EK[1]; + DK[48]:= MulInv(EK[0]); + for i:= 0 to 6 do + begin + DK[47-i*6]:= EK[i*6+5]; + DK[46-i*6]:= EK[i*6+4]; + DK[45-i*6]:= MulInv(EK[i*6+9]); + DK[44-i*6]:= -EK[i*6+7]; + DK[43-i*6]:= -EK[i*6+8]; + DK[42-i*6]:= MulInv(EK[i*6+6]); + end; + DK[5]:= EK[47]; + DK[4]:= EK[46]; + DK[3]:= MulInv(EK[51]); + DK[2]:= -EK[50]; + DK[1]:= -EK[49]; + DK[0]:= MulInv(EK[48]); +end; + +procedure TIDEA.Burn; +begin + FillChar(EK,Sizeof(EK),0); + FillChar(DK,Sizeof(DK),0); + inherited Burn; +end; + +procedure Mul(var x: word; const y: word); +var + p: DWord; + t16: word; +begin + p:= DWord(x)*y; + if p= 0 then + x:= 1 - x - y + else + begin + x:= p shr 16; + t16:= p and $FFFF; + x:= t16 - x; + if (t16 < x) then + Inc(x); + end; +end; + +procedure TIDEA.EncryptECB(const InData; var OutData); +var + x: array[1..4] of word; + s3, s2: word; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + PDword(@X[1])^:= PDword(@InData)^; + PDword(@X[3])^:= PDword(dword(@InData)+4)^; + for i:= 1 to 4 do + x[i]:= (x[i] shl 8) or (x[i] shr 8); + for i:= 0 to 7 do + begin + Mul(x[1],EK[(i*6)+0]); + Inc(x[2],EK[(i*6)+1]); + Inc(x[3],EK[(i*6)+2]); + Mul(x[4],EK[(i*6)+3]); + s3:= x[3]; + x[3]:= x[3] xor x[1]; + Mul(x[3],EK[(i*6)+4]); + s2:= x[2]; + x[2]:= x[2] xor x[4]; + Inc(x[2],x[3]); + Mul(x[2],EK[(i*6)+5]); + Inc(x[3],x[2]); + x[1]:= x[1] xor x[2]; + x[4]:= x[4] xor x[3]; + x[2]:= x[2] xor s3; + x[3]:= x[3] xor s2; + end; + Mul(x[1],EK[48]); + Inc(x[3],EK[49]); + Inc(x[2],EK[50]); + Mul(x[4],EK[51]); + x[1]:= (x[1] shl 8) or (x[1] shr 8); + s2:= (x[3] shl 8) or (x[3] shr 8); + x[3]:= (x[2] shl 8) or (x[2] shr 8); + x[4]:= (x[4] shl 8) or (x[4] shr 8); + x[2]:= s2; + PDword(@OutData)^:= PDword(@x[1])^; + PDword(dword(@OutData)+4)^:= PDword(@x[3])^; +end; + +procedure TIDEA.DecryptECB(const InData; var OutData); +var + x: array[1..4] of word; + s3, s2: word; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + PDword(@X[1])^:= PDword(@InData)^; + PDword(@X[3])^:= PDword(dword(@InData)+4)^; + for i:= 1 to 4 do + x[i]:= (x[i] shl 8) or (x[i] shr 8); + for i:= 0 to 7 do + begin + Mul(x[1],DK[(i*6)+0]); + Inc(x[2],DK[(i*6)+1]); + Inc(x[3],DK[(i*6)+2]); + Mul(x[4],DK[(i*6)+3]); + s3:= x[3]; + x[3]:= x[3] xor x[1]; + Mul(x[3],DK[(i*6)+4]); + s2:= x[2]; + x[2]:= x[2] xor x[4]; + Inc(x[2],x[3]); + Mul(x[2],DK[(i*6)+5]); + Inc(x[3],x[2]); + x[1]:= x[1] xor x[2]; + x[4]:= x[4] xor x[3]; + x[2]:= x[2] xor s3; + x[3]:= x[3] xor s2; + end; + Mul(x[1],DK[48]); + Inc(x[3],DK[49]); + Inc(x[2],DK[50]); + Mul(x[4],DK[51]); + x[1]:= (x[1] shl 8) or (x[1] shr 8); + s2:= (x[3] shl 8) or (x[3] shr 8); + x[3]:= (x[2] shl 8) or (x[2] shr 8); + x[4]:= (x[4] shl 8) or (x[4] shr 8); + x[2]:= s2; + PDword(@OutData)^:= PDword(@x[1])^; + PDword(dword(@OutData)+4)^:= PDword(@x[3])^; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TMisty1.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewMisty1; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// +//{$I DCPmisty1.inc} + +function SwapDword(a: dword): dword; +begin + Result:= ((a and $FF) shl 24) or ((a and $FF00) shl 8) or ((a and $FF0000) shr 8) or ((a and $FF000000) shr 24); +end; + +function TMisty1.FI(const FI_IN, FI_KEY: DWord): DWord; +var + d7, d9: DWord; +begin + d9:= (FI_IN shr 7) and $1ff; + d7:= FI_IN and $7f; + d9:= S9Table[d9] xor d7; + d7:= (S7Table[d7] xor d9) and $7f; + d7:= d7 xor ((FI_KEY shr 9) and $7f); + d9:= d9 xor (FI_KEY and $1ff); + d9:= S9Table[d9] xor d7; + Result:= (d7 shl 9) or d9; +end; + +function TMisty1.FO(const FO_IN: DWord; const k: longword): DWord; +var + t0, t1: DWord; +begin + t0:= FO_IN shr 16; + t1:= FO_IN and $FFFF; + t0:= t0 xor KeyData[k]; + t0:= FI(t0,KeyData[((k+5) mod 8) + 8]); + t0:= t0 xor t1; + t1:= t1 xor KeyData[(k+2) mod 8]; + t1:= FI(t1,KeyData[((k+1) mod 8) + 8]); + t1:= t1 xor t0; + t0:= t0 xor KeyData[(k+7) mod 8]; + t0:= FI(t0,KeyData[((k+3) mod 8) + 8]); + t0:= t0 xor t1; + t1:= t1 xor KeyData[(k+4) mod 8]; + Result:= (t1 shl 16) or t0; +end; + +function TMisty1.FL(const FL_IN: DWord; const k: longword): DWord; +var + d0, d1: DWord; + t: byte; +begin + d0:= FL_IN shr 16; + d1:= FL_IN and $FFFF; + if (k mod 2)<> 0 then + begin + t:= (k-1) div 2; + d1:= d1 xor (d0 and KeyData[((t + 2) mod 8) + 8]); + d0:= d0 xor (d1 or KeyData[(t + 4) mod 8]); + end + else + begin + t:= k div 2; + d1:= d1 xor (d0 and KeyData[t]); + d0:= d0 xor (d1 or KeyData[((t+6) mod 8) + 8]); + end; + Result:= (d0 shl 16) or d1; +end; + +function TMisty1.FLINV(const FL_IN: DWord; const k: longword): DWord; +var + d0, d1: DWord; + t: byte; +begin + d0:= FL_IN shr 16; + d1:= FL_IN and $FFFF; + if (k mod 2)<> 0 then + begin + t:= (k-1) div 2; + d0:= d0 xor (d1 or KeyData[(t+4) mod 8]); + d1:= d1 xor (d0 and KeyData[((t+2) mod 8) + 8]); + end + else + begin + t:= k div 2; + d0:= d0 xor (d1 or KeyData[((t+6) mod 8) + 8]); + d1:= d1 xor (d0 and KeyData[t]); + end; + Result:= (d0 shl 16) or d1; +end; + +procedure TMisty1.InitKey(const Key; Size: longword); +var + KeyB: array[0..15] of byte; + i: longword; +begin +burn; + FillChar(KeyB,Sizeof(KeyB),0); + Move(Key,KeyB,Size div 8); + for i:= 0 to 7 do + KeyData[i]:= (KeyB[i*2] * 256) + KeyB[i*2+1]; + for i:= 0 to 7 do + begin + KeyData[i+8]:= FI(KeyData[i],KeyData[(i+1) mod 8]); + KeyData[i+16]:= KeyData[i+8] and $1FF; + KeyData[i+24]:= KeyData[i+8] shr 9; + end; +end; + +procedure TMisty1.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure TMisty1.EncryptECB(const InData; var OutData); +var + d0, d1: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + d0:= SwapDWord(PDWord(@InData)^); + d1:= SwapDWord(PDWord(longword(@InData)+4)^); + for i:= 0 to NUMROUNDSMY1-1 do + begin + if (i mod 2)= 0 then + begin + d0:= FL(D0,i); + d1:= FL(D1,i+1); + d1:= d1 xor FO(d0,i); + end + else + d0:= d0 xor FO(d1,i); + end; + d0:= FL(d0,NUMROUNDSMY1); + d1:= FL(d1,NUMROUNDSMY1+1); + PDWord(@OutData)^:= SwapDWord(d1); + PDWord(longword(@OutData)+4)^:= SwapDWord(d0); +end; + +procedure TMisty1.DecryptECB(const InData; var OutData); +var + d0, d1: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + d1:= SwapDWord(PDWord(@InData)^); + d0:= SwapDWord(PDWord(longword(@InData)+4)^); + d1:= FLINV(d1,NUMROUNDSMY1+1); + d0:= FLINV(d0,NUMROUNDSMY1); + for i:= NUMROUNDSMY1-1 downto 0 do + begin + if (i mod 2)= 0 then + begin + d1:= d1 xor FO(d0,i); + d0:= FLINV(D0,i); + d1:= FLINV(D1,i+1); + end + else + d0:= d0 xor FO(d1,i); + end; + PDWord(@OutData)^:= SwapDWord(d0); + PDWord(longword(@OutData)+4)^:= SwapDWord(d1); +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TRC2.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewRC2; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +function LRot16(a, n: word): word; +begin + Result:= (a shl n) or (a shr (16-n)); +end; + +function RRot16(a, n: word): word; +begin + Result:= (a shr n) or (a shl (16-n)); +end; + +procedure TRC2.InitKey(const Key; Size: longword); +var + i: longword; + KeyB: array[0..127] of byte; +begin +burn; + Move(Key,KeyB,Size div 8); + for i:= (Size div 8) to 127 do + KeyB[i]:= sBoxRC2[(KeyB[i-(Size div 8)]+KeyB[i-1]) and $FF]; + KeyB[0]:= sBoxRC2[KeyB[0]]; + Move(KeyB,KeyData,Sizeof(KeyData)); +end; + +procedure TRC2.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure TRC2.EncryptECB(const InData; var OutData); +var + i, j: longword; + w: array[0..3] of word; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Pdword(@w[0])^:= Pdword(@InData)^; + Pdword(@w[2])^:= Pdword(longword(@InData)+4)^; + for i:= 0 to 15 do + begin + j:= i*4; + w[0]:= LRot16((w[0]+(w[1] and (not w[3]))+(w[2] and w[3])+KeyData[j+0]),1); + w[1]:= LRot16((w[1]+(w[2] and (not w[0]))+(w[3] and w[0])+KeyData[j+1]),2); + w[2]:= LRot16((w[2]+(w[3] and (not w[1]))+(w[0] and w[1])+KeyData[j+2]),3); + w[3]:= LRot16((w[3]+(w[0] and (not w[2]))+(w[1] and w[2])+KeyData[j+3]),5); + if (i= 4) or (i= 10) then + begin + w[0]:= w[0]+KeyData[w[3] and 63]; + w[1]:= w[1]+KeyData[w[0] and 63]; + w[2]:= w[2]+KeyData[w[1] and 63]; + w[3]:= w[3]+KeyData[w[2] and 63]; + end; + end; + Pdword(@OutData)^:= Pdword(@w[0])^; + Pdword(longword(@OutData)+4)^:= Pdword(@w[2])^; +end; + +procedure TRC2.DecryptECB(const InData; var OutData); +var + i, j: longword; + w: array[0..3] of word; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Pdword(@w[0])^:= Pdword(@InData)^; + Pdword(@w[2])^:= Pdword(longword(@InData)+4)^; + for i:= 15 downto 0 do + begin + j:= i*4; + w[3]:= RRot16(w[3],5)-(w[0] and (not w[2]))-(w[1] and w[2])-KeyData[j+3]; + w[2]:= RRot16(w[2],3)-(w[3] and (not w[1]))-(w[0] and w[1])-KeyData[j+2]; + w[1]:= RRot16(w[1],2)-(w[2] and (not w[0]))-(w[3] and w[0])-KeyData[j+1]; + w[0]:= RRot16(w[0],1)-(w[1] and (not w[3]))-(w[2] and w[3])-KeyData[j+0]; + if (i= 5) or (i= 11) then + begin + w[3]:= w[3]-KeyData[w[2] and 63]; + w[2]:= w[2]-KeyData[w[1] and 63]; + w[1]:= w[1]-KeyData[w[0] and 63]; + w[0]:= w[0]-KeyData[w[3] and 63]; + end; + end; + Pdword(@OutData)^:= Pdword(@w[0])^; + Pdword(longword(@OutData)+4)^:= Pdword(@w[2])^; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TRC4.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewRC4; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure Trc4.InitKey(const Key; Size: longword; InitVector: pointer); +var + i, j, t: longword; + xKey: array[0..255] of byte; +begin +// if fInitialized then + Burn; +// inherited Init(Key,Size,nil); + Size:= Size div 8; + i:= 0; + while i< 255 do + begin + KeyData[i]:= i; + xKey[i]:= PByte(longword(@Key)+(i mod Size))^; + KeyData[i+1]:= i+1; + xKey[i+1]:= PByte(longword(@Key)+((i+1) mod Size))^; + KeyData[i+2]:= i+2; + xKey[i+2]:= PByte(longword(@Key)+((i+2) mod Size))^; + KeyData[i+3]:= i+3; + xKey[i+3]:= PByte(longword(@Key)+((i+3) mod Size))^; + KeyData[i+4]:= i+4; + xKey[i+4]:= PByte(longword(@Key)+((i+4) mod Size))^; + KeyData[i+5]:= i+5; + xKey[i+5]:= PByte(longword(@Key)+((i+5) mod Size))^; + KeyData[i+6]:= i+6; + xKey[i+6]:= PByte(longword(@Key)+((i+6) mod Size))^; + KeyData[i+7]:= i+7; + xKey[i+7]:= PByte(longword(@Key)+((i+7) mod Size))^; + Inc(i,8); + end; + j:= 0; + i:= 0; + while i< 255 do + begin + j:= (j+KeyData[i]+xKey[i]) and $FF; + t:= KeyData[i]; + KeyData[i]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+1]+xKey[i+1]) and $FF; + t:= KeyData[i+1]; + KeyData[i+1]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+2]+xKey[i+2]) and $FF; + t:= KeyData[i+2]; + KeyData[i+2]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+3]+xKey[i+3]) and $FF; + t:= KeyData[i+3]; + KeyData[i+3]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+4]+xKey[i+4]) and $FF; + t:= KeyData[i+4]; + KeyData[i+4]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+5]+xKey[i+5]) and $FF; + t:= KeyData[i+5]; + KeyData[i+5]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+6]+xKey[i+6]) and $FF; + t:= KeyData[i+6]; + KeyData[i+6]:= KeyData[j]; + KeyData[j]:= t; + j:= (j+KeyData[i+7]+xKey[i+7]) and $FF; + t:= KeyData[i+7]; + KeyData[i+7]:= KeyData[j]; + KeyData[j]:= t; + Inc(i,8); + end; + Move(KeyData,KeyOrg,Sizeof(KeyOrg)); +end; + +procedure Trc4.Reset; +begin + Move(KeyOrg,KeyData,Sizeof(KeyData)); +end; + +procedure Trc4.Burn; +begin + FillChar(KeyOrg,Sizeof(KeyOrg),$FF); + FillChar(KeyData,Sizeof(KeyData),$FF); +// inherited Burn; +end; + +procedure Trc4.Encrypt(const InData; var OutData; Size: longword); +var + i, j, t, k: longword; +begin +// if not fInitialized then +// raise EDCP_cipher.Create('Cipher not initialized'); + i:= 0; j:= 0; + for k:= 0 to Size-1 do + begin + i:= (i + 1) and $FF; + t:= KeyData[i]; + j:= (j + t) and $FF; + KeyData[i]:= KeyData[j]; + KeyData[j]:= t; + t:= (t + KeyData[i]) and $FF; + Pbytearray(@OutData)^[k]:= Pbytearray(@InData)^[k] xor KeyData[t]; + end; +end; + +procedure Trc4.Decrypt(const InData; var OutData; Size: longword); +var + i, j, t, k: longword; +begin +// if not fInitialized then +// raise EDCP_cipher.Create('Cipher not initialized'); + i:= 0; j:= 0; + for k:= 0 to Size-1 do + begin + i:= (i + 1) and $FF; + t:= KeyData[i]; + j:= (j + t) and $FF; + KeyData[i]:= KeyData[j]; + KeyData[j]:= t; + t:= (t + KeyData[i]) and $FF; + Pbytearray(@OutData)^[k]:= Pbytearray(@InData)^[k] xor KeyData[t]; + end; +end; + + + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TRC5.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewRC5; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + + + +function RRot32(a, b: longword): longword; +begin + Result:= (a shr b) or (a shl (32-b)); +end; + +procedure TRC5.InitKey(const Key; Size: longword); +var + xKeyD: array[0..63] of DWord; + i, j, k, xKeyLen: longword; + A, B: DWord; +begin +burn; + FillChar(xKeyD,Sizeof(xKeyD),0); + Size:= Size div 8; + Move(Key,xKeyD,Size); + xKeyLen:= Size div 4; + if (Size mod 4)<> 0 then + Inc(xKeyLen); + Move(sBoxRC5,KeyData,(NUMROUNDSRC5+1)*8); + i:= 0; j:= 0; + A:= 0; B:= 0; + if xKeyLen> ((NUMROUNDSRC5+1)*2) then + k:= xKeyLen*3 + else + k:= (NUMROUNDSRC5+1)*6; + for k:= k downto 1 do + begin + A:= LRot32(KeyData[i]+A+B,3); + KeyData[i]:= A; + B:= LRot32(xKeyD[j]+A+B,A+B); + xKeyD[j]:= B; + i:= (i+1) mod ((NUMROUNDSRC5+1)*2); + j:= (j+1) mod xKeyLen; + end; + FillChar(xKeyD,Sizeof(xKeyD),0); +end; + +procedure TRC5.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),$FF); + inherited Burn; +end; + +procedure TRC5.EncryptECB(const InData; var OutData); +var + A, B: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + A:= PDword(@InData)^ + KeyData[0]; + B:= PDword(longword(@InData)+4)^ + KeyData[1]; + for i:= 1 to NUMROUNDSRC5 do + begin + A:= A xor B; + A:= LRot32(A,B)+KeyData[2*i]; + B:= B xor A; + B:= LRot32(B,A)+KeyData[(2*i)+1]; + end; + PDword(@OutData)^:= A; + PDword(longword(@OutData)+4)^:= B; +end; + +procedure TRC5.DecryptECB(const InData; var OutData); +var + A, B: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + A:= PDword(@InData)^; + B:= PDword(longword(@InData)+4)^; + for i:= NUMROUNDSRC5 downto 1 do + begin + B:= RRot32(B-KeyData[(2*i)+1],A); + B:= B xor A; + A:= RRot32(A-KeyData[2*i],B); + A:= A xor B; + end; + PDword(@OutData)^:= A - KeyData[0]; + PDword(longword(@OutData)+4)^:= B - KeyData[1]; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TTEA.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewTEA; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TTEA.InitKey(const Key; Size: longword); +begin +burn; + FillChar(KeyData,Sizeof(KeyData),0); + Move(Key,KeyData,Size div 8); + KeyData[0]:= SwapDWord(KeyData[0]); KeyData[1]:= SwapDWord(KeyData[1]); + KeyData[2]:= SwapDWord(KeyData[2]); KeyData[3]:= SwapDWord(KeyData[3]); +end; + +procedure TTEA.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure TTEA.EncryptECB(const InData; var OutData); +var + a, b, c, d, x, y, n, sum: dword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + + x:= SwapDWord(pdword(@InData)^); + y:= SwapDWord(pdword(longword(@InData)+4)^); + sum:= 0; a:= KeyData[0]; b:= KeyData[1]; c:= KeyData[2]; d:= KeyData[3]; + for n:= 1 to Rounds do + begin + Inc(sum,Delta); + Inc(x,(y shl 4) + (a xor y) + (sum xor (y shr 5)) + b); + Inc(y,(x shl 4) + (c xor x) + (sum xor (x shr 5)) + d); + end; + pdword(@OutData)^:= SwapDWord(x); + pdword(longword(@OutData)+4)^:= SwapDWord(y); +end; + +procedure TTEA.DecryptECB(const InData; var OutData); +var + a, b, c, d, x, y, n, sum: dword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + + x:= SwapDWord(pdword(@InData)^); + y:= SwapDWord(pdword(longword(@InData)+4)^); + sum:= Delta shl 5; a:= KeyData[0]; b:= KeyData[1]; c:= KeyData[2]; d:= KeyData[3]; + for n:= 1 to Rounds do + begin + Dec(y,(x shl 4) + (c xor x) + (sum xor (x shr 5)) + d); + Dec(x,(y shl 4) + (a xor y) + (sum xor (y shr 5)) + b); + Dec(sum,Delta); + end; + pdword(@OutData)^:= SwapDWord(x); + pdword(longword(@OutData)+4)^:= SwapDWord(y); +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TDES.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewDES; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure hperm_op(var a, t: dword; n, m: dword); +begin + t:= ((a shl (16 - n)) xor a) and m; + a:= a xor t xor (t shr (16 - n)); +end; + +procedure perm_op(var a, b, t: dword; n, m: dword); +begin + t:= ((a shr n) xor b) and m; + b:= b xor t; + a:= a xor (t shl n); +end; + +procedure Tcustomdes.DoInit(KeyB: PByteArray; KeyData: PDwordArray); +var + c, d, t, s, t2, i: dword; +begin + c:= KeyB^[0] or (KeyB^[1] shl 8) or (KeyB^[2] shl 16) or (KeyB^[3] shl 24); + d:= KeyB^[4] or (KeyB^[5] shl 8) or (KeyB^[6] shl 16) or (KeyB^[7] shl 24); + perm_op(d,c,t,4,$0f0f0f0f); + hperm_op(c,t,dword(-2),$cccc0000); + hperm_op(d,t,dword(-2),$cccc0000); + perm_op(d,c,t,1,$55555555); + perm_op(c,d,t,8,$00ff00ff); + perm_op(d,c,t,1,$55555555); + d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or + ((c and $f0000000) shr 4); + c:= c and $fffffff; + for i:= 0 to 15 do + begin + if shifts2[i]<> 0 then + begin + c:= ((c shr 2) or (c shl 26)); + d:= ((d shr 2) or (d shl 26)); + end + else + begin + c:= ((c shr 1) or (c shl 27)); + d:= ((d shr 1) or (d shl 27)); + end; + c:= c and $fffffff; + d:= d and $fffffff; + s:= des_skb[0,c and $3f] or + des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or + des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or + des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; + t:= des_skb[4,d and $3f] or + des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or + des_skb[6, (d shr 15) and $3f ] or + des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; + t2:= ((t shl 16) or (s and $ffff)); + KeyData^[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); + t2:= ((s shr 16) or (t and $ffff0000)); + KeyData^[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); + end; +end; + +procedure Tcustomdes.EncryptBlock(const InData; var OutData; KeyData: PDWordArray); +var + l, r, t, u: dword; + i: longint; +begin + r:= PDword(@InData)^; + l:= PDword(dword(@InData)+4)^; + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 0; + while i< 32 do + begin + u:= r xor KeyData^[i ]; + t:= r xor KeyData^[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData^[i+2]; + t:= l xor KeyData^[i+3]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData^[i+4]; + t:= r xor KeyData^[i+5]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData^[i+6]; + t:= l xor KeyData^[i+7]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Inc(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + PDword(@OutData)^:= l; + PDword(dword(@OutData)+4)^:= r; +end; + +procedure Tcustomdes.DecryptBlock(const InData; var OutData; KeyData: PDWordArray); +var + l, r, t, u: dword; + i: longint; +begin + r:= PDword(@InData)^; + l:= PDword(dword(@InData)+4)^; + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 30; + while i> 0 do + begin + u:= r xor KeyData^[i ]; + t:= r xor KeyData^[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData^[i-2]; + t:= l xor KeyData^[i-1]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData^[i-4]; + t:= r xor KeyData^[i-3]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData^[i-6]; + t:= l xor KeyData^[i-5]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Dec(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + PDword(@OutData)^:= l; + PDword(dword(@OutData)+4)^:= r; +end; + +procedure Tdes.InitKey(const Key; Size: longword); +var + KeyB: array[0..7] of byte; +begin +burn; + FillChar(KeyB,Sizeof(KeyB),0); + Move(Key,KeyB,Size div 8); + DoInit(@KeyB,@KeyData); +end; + +procedure Tdes.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure Tdes.EncryptECB(const InData; var OutData); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + EncryptBlock(InData,OutData,@KeyData); +end; + +procedure Tdes.DecryptECB(const InData; var OutData); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + DecryptBlock(InData,OutData,@KeyData); +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor T3DES.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function New3DES; +begin +New(Result, Create); +//burn; +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure T3DES.InitKey(const Key; Size: longword); +var + KeyB: array[0..2,0..7] of byte; +begin +burn; + FillChar(KeyB,Sizeof(KeyB),0); + Move(Key,KeyB,Size div 8); + DoInit(@KeyB[0],@KeyData[0]); + DoInit(@KeyB[1],@KeyData[1]); + if Size> 128 then + DoInit(@KeyB[2],@KeyData[2]) + else + Move(KeyData[0],KeyData[2],128); +end; + +procedure T3DES.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),0); + inherited Burn; +end; + +procedure T3des.EncryptECB(const InData; var OutData); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + EncryptBlock(InData,OutData,@KeyData[0]); + DecryptBlock(OutData,OutData,@KeyData[1]); + EncryptBlock(OutData,OutData,@KeyData[2]); +end; + +procedure T3des.DecryptECB(const InData; var OutData); +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + DecryptBlock(InData,OutData,@KeyData[2]); + EncryptBlock(OutData,OutData,@KeyData[1]); + DecryptBlock(OutData,OutData,@KeyData[0]); +end; + + +var + ice_sbox: array[0..3,0..1023] of dword; + ice_sboxdone: boolean; + +const + ice_smod: array[0..3,0..3] of dword= ( + (333, 313, 505, 369), + (379, 375, 319, 391), + (361, 445, 451, 397), + (397, 425, 395, 505)); + ice_sxor: array[0..3,0..3] of dword= ( + ($83, $85, $9b, $cd), + ($cc, $a7, $ad, $41), + ($4b, $2e, $d4, $33), + ($ea, $cb, $2e, $04)); + ice_keyrot: array[0..15] of dword= ( + 0, 1, 2, 3, 2, 1, 3, 0, + 1, 3, 2, 0, 3, 1, 0, 2); + ice_pbox: array[0..31] of dword= ( + $00000001, $00000080, $00000400, $00002000, + $00080000, $00200000, $01000000, $40000000, + $00000008, $00000020, $00000100, $00004000, + $00010000, $00800000, $04000000, $20000000, + $00000004, $00000010, $00000200, $00008000, + $00020000, $00400000, $08000000, $10000000, + $00000002, $00000040, $00000800, $00001000, + $00040000, $00100000, $02000000, $80000000); + +{******************************************************************************} +function gf_mult(a, b, m: dword): dword; +var + res: dword; +begin + res:= 0; + while b<> 0 do + begin + if (b and 1)<> 0 then + res:= res xor a; + a:= a shl 1; + b:= b shr 1; + if a>= 256 then + a:= a xor m; + end; + Result:= res; +end; + +function gf_exp7(b, m: dword): dword; +var + x: dword; +begin + if b= 0 then + Result:= 0 + else + begin + x:= gf_mult(b,b,m); + x:= gf_mult(b,x,m); + x:= gf_mult(x,x,m); + Result:= gf_mult(b,x,m); + end; +end; + +function ice_perm32(x: dword): dword; +var + res: dword; + pbox: pdword; +begin + res:= 0; + pbox:= @ice_pbox; + while x<> 0 do + begin + if (x and 1)<> 0 then + res:= res or pbox^; + Inc(pbox); + x:= x shr 1; + end; + Result:= res; +end; + +procedure ice_sboxes_init; +var + i, col, row: dword; + x: dword; +begin + for i:= 0 to 1023 do + begin + col:= (i shr 1) and $FF; + row:= (i and 1) or ((i and $200) shr 8); + x:= gf_exp7(col xor ice_sxor[0,row],ice_smod[0,row]) shl 24; + ice_sbox[0,i]:= ice_perm32(x); + x:= gf_exp7(col xor ice_sxor[1,row],ice_smod[1,row]) shl 16; + ice_sbox[1,i]:= ice_perm32(x); + x:= gf_exp7(col xor ice_sxor[2,row],ice_smod[2,row]) shl 8; + ice_sbox[2,i]:= ice_perm32(x); + x:= gf_exp7(col xor ice_sxor[3,row],ice_smod[3,row]); + ice_sbox[3,i]:= ice_perm32(x); + end; +end; + +function Tcustomice.f(p, sk: dword): dword; +var + tl, tr, al, ar: dword; +begin + tl:= ((p shr 16) and $3ff) or (((p shr 14) or (p shl 18)) and $ffc00); + tr:= (p and $3ff) or ((p shl 2) and $ffc00); + al:= ik_keysched[sk,2] and (tl xor tr); + ar:= al xor tr; + al:= al xor tl; + al:= al xor ik_keysched[sk,0]; + ar:= ar xor ik_keysched[sk,1]; + Result:= ice_sbox[0,al shr 10] or ice_sbox[1,al and $3ff] or + ice_sbox[2,ar shr 10] or ice_sbox[3,ar and $3ff]; +end; + + +procedure Tcustomice.key_sched_build(kb: pwordarray; n: dword; keyrot: pdwordarray); +var + i, j, k, kr: dword; + keys: pdwordarray; + currentsk: pdword; + currentkb: pword; + bit: dword; +begin + for i:= 0 to 7 do + begin + kr:= keyrot^[i]; + keys:= @ik_keysched[n+i]; + for j:= 0 to 2 do + keys^[j]:= 0; + for j:= 0 to 14 do + begin + currentsk:= @keys^[j mod 3]; + for k:= 0 to 3 do + begin + currentkb:= @kb^[(kr + k) and 3]; + bit:= currentkb^ and 1; + currentsk^:= (currentsk^ shl 1) or bit; + currentkb^:= (currentkb^ shr 1) or ((bit xor 1) shl 15); + end; + end; + end; +end; + +procedure Tcustomice.InitIce(const Key; Size: longword; n: dword); +var + i, j: dword; + kb: array[0..3] of word; + keyb: array[0..15] of byte; +begin + FillChar(keyb,Sizeof(keyb),0); + Move(key,keyb,Size div 8); + if n> 0 then + rounds:= 16 * n + else + rounds:= 8; + + if rounds= 8 then + begin + for i:= 0 to 4 do + kb[3 - i]:= (keyb[i*2] shl 8) or keyb[i*2 + 1]; + key_sched_build(@kb,0,@ice_keyrot); + end + else + begin + for i:= 0 to (n-1) do + begin + for j:= 0 to 3 do + kb[3-j]:= (keyb[i*8 + j*2] shl 8) or keyb[i*8 + j*2 + 1]; + key_sched_build(@kb,i*8,@ice_keyrot); + key_sched_build(@kb,rounds - 8 - i*8,@ice_keyrot[8]); + end; + end; +end; + +procedure Tcustomice.Burn; +begin + FillChar(ik_keysched,Sizeof(ik_keysched),0); + Rounds:= 0; + inherited Burn; +end; + +procedure Tcustomice.EncryptECB(const InData; var OutData); +var + i, l, r: dword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + l:= SwapDWord(Pdword(@InData)^); + r:= SwapDWord(Pdword(longword(@InData)+4)^); + i:= 0; + while i< rounds do + begin + l:= l xor f(r,i); + r:= r xor f(l,i+1); + Inc(i,2); + end; + Pdword(@OutData)^:= SwapDWord(r); + Pdword(longword(@OutData)+4)^:= SwapDWord(l); +end; + +procedure Tcustomice.DecryptECB(const InData; var OutData); +var + l, r: dword; + i: integer; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + l:= SwapDWord(Pdword(@InData)^); + r:= SwapDWord(Pdword(longword(@InData)+4)^); + i:= rounds-1; + while i> 0 do + begin + l:= l xor f(r,i); + r:= r xor f(l,i-1); + Dec(i,2); + end; + Pdword(@OutData)^:= SwapDWord(r); + Pdword(longword(@OutData)+4)^:= SwapDWord(l); +end; + + + +destructor TICE.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewICE; +begin +New(Result, Create); + if not ice_sboxdone then + begin + ice_sboxes_init; + ice_sboxdone:= true; + end; +// code +end; + +destructor TICE2.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure Tice.InitKey(const Key; Size: longword); +begin +burn; + InitIce(Key,Size,1); +end; + + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewICE2; +begin +New(Result, Create); + if not ice_sboxdone then + begin + ice_sboxes_init; + ice_sboxdone:= true; + end; + +// code +end; + +destructor TThinICE.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure Tice2.InitKey(const Key; Size: longword); +begin +burn; + InitIce(Key,Size,2); +end; + + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewThinICE; +begin +New(Result, Create); + if not ice_sboxdone then + begin + ice_sboxes_init; + ice_sboxdone:= true; + end; + +// code +end; + +procedure Tthinice.InitKey(const Key; Size: longword); +begin +burn; + InitIce(Key,Size,0); +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TCast256.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewCast256; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +function F1(a,rk,mk: DWord): DWord; +var + t: DWord; +begin + t:= LRot32(mk + a,rk); + Result:= ((S1[t shr 24] xor S2[(t shr 16) and $FF]) - S3[(t shr 8) and $FF]) + S4[t and $FF]; +end; +function F2(a,rk,mk: DWord): DWord; +var + t: DWord; +begin + t:= LRot32(mk xor a,rk); + Result:= ((S1[t shr 24] - S2[(t shr 16) and $FF]) + S3[(t shr 8) and $FF]) xor S4[t and $FF]; +end; +function F3(a,rk,mk: DWord): DWord; +var + t: DWord; +begin + t:= LRot32(mk - a,rk); + Result:= ((S1[t shr 24] + S2[(t shr 16) and $FF]) xor S3[(t shr 8) and $FF]) - S4[t and $FF]; +end; + + +procedure Tcast256.InitKey(const Key; Size: longword); +var + x: array[0..7] of DWord; + cm, cr: DWord; + i, j: longword; + tr, tm: array[0..7] of DWord; +begin +burn; + Size:= Size div 8; + + FillChar(x,Sizeof(x),0); + Move(Key,x,Size); + + cm:= $5a827999; + cr:= 19; + for i:= 0 to 7 do + x[i]:= (x[i] shl 24) or ((x[i] shl 8) and $FF0000) or ((x[i] shr 8) and $FF00) or (x[i] shr 24); + for i:= 0 to 11 do + begin + for j:= 0 to 7 do + begin + tm[j]:= cm; + Inc(cm,$6ed9eba1); + tr[j]:= cr; + Inc(cr,17); + end; + x[6]:= x[6] xor f1(x[7],tr[0],tm[0]); + x[5]:= x[5] xor f2(x[6],tr[1],tm[1]); + x[4]:= x[4] xor f3(x[5],tr[2],tm[2]); + x[3]:= x[3] xor f1(x[4],tr[3],tm[3]); + x[2]:= x[2] xor f2(x[3],tr[4],tm[4]); + x[1]:= x[1] xor f3(x[2],tr[5],tm[5]); + x[0]:= x[0] xor f1(x[1],tr[6],tm[6]); + x[7]:= x[7] xor f2(x[0],tr[7],tm[7]); + + for j:= 0 to 7 do + begin + tm[j]:= cm; + Inc(cm,$6ed9eba1); + tr[j]:= cr; + Inc(cr,17); + end; + x[6]:= x[6] xor f1(x[7],tr[0],tm[0]); + x[5]:= x[5] xor f2(x[6],tr[1],tm[1]); + x[4]:= x[4] xor f3(x[5],tr[2],tm[2]); + x[3]:= x[3] xor f1(x[4],tr[3],tm[3]); + x[2]:= x[2] xor f2(x[3],tr[4],tm[4]); + x[1]:= x[1] xor f3(x[2],tr[5],tm[5]); + x[0]:= x[0] xor f1(x[1],tr[6],tm[6]); + x[7]:= x[7] xor f2(x[0],tr[7],tm[7]); + + Kr[i,0]:= x[0] and 31; + Kr[i,1]:= x[2] and 31; + Kr[i,2]:= x[4] and 31; + Kr[i,3]:= x[6] and 31; + Km[i,0]:= x[7]; + Km[i,1]:= x[5]; + Km[i,2]:= x[3]; + Km[i,3]:= x[1]; + end; + FillChar(x,Sizeof(x),$FF); +end; + +procedure Tcast256.Burn; +begin + FillChar(Kr,Sizeof(Kr),$FF); + FillChar(Km,Sizeof(Km),$FF); + inherited Burn; +end; + +procedure Tcast256.EncryptECB(const InData; var OutData); +var + A: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + A[0]:= PDWord(@InData)^; + A[1]:= PDWord(longword(@InData)+4)^; + A[2]:= PDWord(longword(@InData)+8)^; + A[3]:= PDWord(longword(@InData)+12)^; + + A[0]:= SwapDWord(A[0]); + A[1]:= SwapDWord(A[1]); + A[2]:= SwapDWord(A[2]); + A[3]:= SwapDWord(A[3]); + A[2]:= A[2] xor f1(A[3],kr[0,0],km[0,0]); + A[1]:= A[1] xor f2(A[2],kr[0,1],km[0,1]); + A[0]:= A[0] xor f3(A[1],kr[0,2],km[0,2]); + A[3]:= A[3] xor f1(A[0],kr[0,3],km[0,3]); + A[2]:= A[2] xor f1(A[3],kr[1,0],km[1,0]); + A[1]:= A[1] xor f2(A[2],kr[1,1],km[1,1]); + A[0]:= A[0] xor f3(A[1],kr[1,2],km[1,2]); + A[3]:= A[3] xor f1(A[0],kr[1,3],km[1,3]); + A[2]:= A[2] xor f1(A[3],kr[2,0],km[2,0]); + A[1]:= A[1] xor f2(A[2],kr[2,1],km[2,1]); + A[0]:= A[0] xor f3(A[1],kr[2,2],km[2,2]); + A[3]:= A[3] xor f1(A[0],kr[2,3],km[2,3]); + A[2]:= A[2] xor f1(A[3],kr[3,0],km[3,0]); + A[1]:= A[1] xor f2(A[2],kr[3,1],km[3,1]); + A[0]:= A[0] xor f3(A[1],kr[3,2],km[3,2]); + A[3]:= A[3] xor f1(A[0],kr[3,3],km[3,3]); + A[2]:= A[2] xor f1(A[3],kr[4,0],km[4,0]); + A[1]:= A[1] xor f2(A[2],kr[4,1],km[4,1]); + A[0]:= A[0] xor f3(A[1],kr[4,2],km[4,2]); + A[3]:= A[3] xor f1(A[0],kr[4,3],km[4,3]); + A[2]:= A[2] xor f1(A[3],kr[5,0],km[5,0]); + A[1]:= A[1] xor f2(A[2],kr[5,1],km[5,1]); + A[0]:= A[0] xor f3(A[1],kr[5,2],km[5,2]); + A[3]:= A[3] xor f1(A[0],kr[5,3],km[5,3]); + + A[3]:= A[3] xor f1(A[0],kr[6,3],km[6,3]); + A[0]:= A[0] xor f3(A[1],kr[6,2],km[6,2]); + A[1]:= A[1] xor f2(A[2],kr[6,1],km[6,1]); + A[2]:= A[2] xor f1(A[3],kr[6,0],km[6,0]); + A[3]:= A[3] xor f1(A[0],kr[7,3],km[7,3]); + A[0]:= A[0] xor f3(A[1],kr[7,2],km[7,2]); + A[1]:= A[1] xor f2(A[2],kr[7,1],km[7,1]); + A[2]:= A[2] xor f1(A[3],kr[7,0],km[7,0]); + A[3]:= A[3] xor f1(A[0],kr[8,3],km[8,3]); + A[0]:= A[0] xor f3(A[1],kr[8,2],km[8,2]); + A[1]:= A[1] xor f2(A[2],kr[8,1],km[8,1]); + A[2]:= A[2] xor f1(A[3],kr[8,0],km[8,0]); + A[3]:= A[3] xor f1(A[0],kr[9,3],km[9,3]); + A[0]:= A[0] xor f3(A[1],kr[9,2],km[9,2]); + A[1]:= A[1] xor f2(A[2],kr[9,1],km[9,1]); + A[2]:= A[2] xor f1(A[3],kr[9,0],km[9,0]); + A[3]:= A[3] xor f1(A[0],kr[10,3],km[10,3]); + A[0]:= A[0] xor f3(A[1],kr[10,2],km[10,2]); + A[1]:= A[1] xor f2(A[2],kr[10,1],km[10,1]); + A[2]:= A[2] xor f1(A[3],kr[10,0],km[10,0]); + A[3]:= A[3] xor f1(A[0],kr[11,3],km[11,3]); + A[0]:= A[0] xor f3(A[1],kr[11,2],km[11,2]); + A[1]:= A[1] xor f2(A[2],kr[11,1],km[11,1]); + A[2]:= A[2] xor f1(A[3],kr[11,0],km[11,0]); + A[0]:= SwapDWord(A[0]); + A[1]:= SwapDWord(A[1]); + A[2]:= SwapDWord(A[2]); + A[3]:= SwapDWord(A[3]); + + PDWord(@OutData)^:= A[0]; + PDWord(longword(@OutData)+4)^:= A[1]; + PDWord(longword(@OutData)+8)^:= A[2]; + PDWord(longword(@OutData)+12)^:= A[3]; +end; + +procedure Tcast256.DecryptECB(const InData; var OutData); +var + A: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + A[0]:= PDWord(@InData)^; + A[1]:= PDWord(longword(@InData)+4)^; + A[2]:= PDWord(longword(@InData)+8)^; + A[3]:= PDWord(longword(@InData)+12)^; + + A[0]:= SwapDWord(A[0]); + A[1]:= SwapDWord(A[1]); + A[2]:= SwapDWord(A[2]); + A[3]:= SwapDWord(A[3]); + A[2]:= A[2] xor f1(A[3],kr[11,0],km[11,0]); + A[1]:= A[1] xor f2(A[2],kr[11,1],km[11,1]); + A[0]:= A[0] xor f3(A[1],kr[11,2],km[11,2]); + A[3]:= A[3] xor f1(A[0],kr[11,3],km[11,3]); + A[2]:= A[2] xor f1(A[3],kr[10,0],km[10,0]); + A[1]:= A[1] xor f2(A[2],kr[10,1],km[10,1]); + A[0]:= A[0] xor f3(A[1],kr[10,2],km[10,2]); + A[3]:= A[3] xor f1(A[0],kr[10,3],km[10,3]); + A[2]:= A[2] xor f1(A[3],kr[9,0],km[9,0]); + A[1]:= A[1] xor f2(A[2],kr[9,1],km[9,1]); + A[0]:= A[0] xor f3(A[1],kr[9,2],km[9,2]); + A[3]:= A[3] xor f1(A[0],kr[9,3],km[9,3]); + A[2]:= A[2] xor f1(A[3],kr[8,0],km[8,0]); + A[1]:= A[1] xor f2(A[2],kr[8,1],km[8,1]); + A[0]:= A[0] xor f3(A[1],kr[8,2],km[8,2]); + A[3]:= A[3] xor f1(A[0],kr[8,3],km[8,3]); + A[2]:= A[2] xor f1(A[3],kr[7,0],km[7,0]); + A[1]:= A[1] xor f2(A[2],kr[7,1],km[7,1]); + A[0]:= A[0] xor f3(A[1],kr[7,2],km[7,2]); + A[3]:= A[3] xor f1(A[0],kr[7,3],km[7,3]); + A[2]:= A[2] xor f1(A[3],kr[6,0],km[6,0]); + A[1]:= A[1] xor f2(A[2],kr[6,1],km[6,1]); + A[0]:= A[0] xor f3(A[1],kr[6,2],km[6,2]); + A[3]:= A[3] xor f1(A[0],kr[6,3],km[6,3]); + + A[3]:= A[3] xor f1(A[0],kr[5,3],km[5,3]); + A[0]:= A[0] xor f3(A[1],kr[5,2],km[5,2]); + A[1]:= A[1] xor f2(A[2],kr[5,1],km[5,1]); + A[2]:= A[2] xor f1(A[3],kr[5,0],km[5,0]); + A[3]:= A[3] xor f1(A[0],kr[4,3],km[4,3]); + A[0]:= A[0] xor f3(A[1],kr[4,2],km[4,2]); + A[1]:= A[1] xor f2(A[2],kr[4,1],km[4,1]); + A[2]:= A[2] xor f1(A[3],kr[4,0],km[4,0]); + A[3]:= A[3] xor f1(A[0],kr[3,3],km[3,3]); + A[0]:= A[0] xor f3(A[1],kr[3,2],km[3,2]); + A[1]:= A[1] xor f2(A[2],kr[3,1],km[3,1]); + A[2]:= A[2] xor f1(A[3],kr[3,0],km[3,0]); + A[3]:= A[3] xor f1(A[0],kr[2,3],km[2,3]); + A[0]:= A[0] xor f3(A[1],kr[2,2],km[2,2]); + A[1]:= A[1] xor f2(A[2],kr[2,1],km[2,1]); + A[2]:= A[2] xor f1(A[3],kr[2,0],km[2,0]); + A[3]:= A[3] xor f1(A[0],kr[1,3],km[1,3]); + A[0]:= A[0] xor f3(A[1],kr[1,2],km[1,2]); + A[1]:= A[1] xor f2(A[2],kr[1,1],km[1,1]); + A[2]:= A[2] xor f1(A[3],kr[1,0],km[1,0]); + A[3]:= A[3] xor f1(A[0],kr[0,3],km[0,3]); + A[0]:= A[0] xor f3(A[1],kr[0,2],km[0,2]); + A[1]:= A[1] xor f2(A[2],kr[0,1],km[0,1]); + A[2]:= A[2] xor f1(A[3],kr[0,0],km[0,0]); + A[0]:= SwapDWord(A[0]); + A[1]:= SwapDWord(A[1]); + A[2]:= SwapDWord(A[2]); + A[3]:= SwapDWord(A[3]); + + PDWord(@OutData)^:= A[0]; + PDWord(longword(@OutData)+4)^:= A[1]; + PDWord(longword(@OutData)+8)^:= A[2]; + PDWord(longword(@OutData)+12)^:= A[3]; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TMars.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewMars; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure gen_mask(var x, m: DWord); +var + u: DWord; +begin + u:= x and (x shr 1); u:= u and (u shr 2); + u:= u and (u shr 4); u:= u and (u shr 1) and (u shr 2); + m:= u; + u:= (x xor $FFFFFFFF) and ((x xor $FFFFFFFF) shr 1); u:= u and (u shr 2); + u:= u and (u shr 4); u:= u and (u shr 1) and (u shr 2); + u:= u or m; + m:= (u shl 1) or (u shl 2) or (u shl 3) + or (u shl 4) or (u shl 5) or (u shl 6) + or (u shl 7) or (u shl 8); + m:= (m or u or (u shl 9)) and ((x xor $FFFFFFFF) xor (x shl 1)) and ((x xor $FFFFFFFF) xor (x shr 1)); + m:= m and $FFFFFFFC; +end; + +procedure Tmars.InitKey(const Key; Size: longword); +var + i, j, m, u, w: DWord; + t: array[-7..39] of DWord; + KeyB: array[0..39] of DWord; +begin +burn; + Size:= Size div 8; + FillChar(KeyB,Sizeof(KeyB),0); + Move(Key,KeyB,Size); + Size:= Size div 4; + Move(vk,t,Sizeof(vk)); + for i:= 0 to 38 do + begin + u:= t[i-7] xor t[i-2]; + t[i]:= LRot32(u,3) xor KeyB[i mod DWord(Size)] xor i; + end; + t[39]:= Size; + for j:= 0 to 6 do + begin + for i:= 1 to 39 do + begin + u:= t[i] + s_box[t[i-1] and $1FF]; + t[i]:= LRot32(u,9); + end; + u:= t[0] + s_box[t[39] and $1FF]; + t[0]:= LRot32(u,9); + end; + for i:= 0 to 39 do + KeyData[(7*i) mod 40]:= t[i]; + i:= 5; + repeat + u:= s_box[265+(KeyData[i] and $3)]; + j:= KeyData[i+3] and $1f; + w:= KeyData[i] or $3; + gen_mask(w,m); + KeyData[i]:= w xor (LRot32(u,j) and m); + Inc(i,2); + until i>= 37; +end; + +procedure Tmars.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),$FF); + inherited Burn; +end; + +procedure Tmars.EncryptECB(const InData; var OutData); +var + l, m, r, t: DWord; + blk: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Blk[0]:= PDWord(@InData)^; + Blk[1]:= PDWord(longword(@InData)+4)^; + Blk[2]:= PDWord(longword(@InData)+8)^; + Blk[3]:= PDWord(longword(@InData)+12)^; + + blk[0]:= blk[0] + KeyData[0]; blk[1]:= blk[1] + KeyData[1]; + blk[2]:= blk[2] + KeyData[2]; blk[3]:= blk[3] + KeyData[3]; + blk[1]:= blk[1] xor s_box[ blk[0] and $FF]; + blk[1]:= blk[1] + s_box[((blk[0] shr 8) and $FF) + 256]; + blk[2]:= blk[2] + s_box[ (blk[0] shr 16) and $FF]; + blk[3]:= blk[3] xor s_box[((blk[0] shr 24) and $FF) + 256]; + blk[0]:= RRot32(blk[0], 24); blk[0]:= blk[0] + blk[3]; + blk[2]:= blk[2] xor s_box[ blk[1] and $FF]; + blk[2]:= blk[2] + s_box[((blk[1] shr 8) and $FF) + 256]; + blk[3]:= blk[3] + s_box[ (blk[1] shr 16) and $FF]; + blk[0]:= blk[0] xor s_box[((blk[1] shr 24) and $FF) + 256]; + blk[1]:= RRot32(blk[1], 24); blk[1]:= blk[1] + blk[2]; + blk[3]:= blk[3] xor s_box[ blk[2] and $FF]; + blk[3]:= blk[3] + s_box[((blk[2] shr 8) and $FF) + 256]; + blk[0]:= blk[0] + s_box[ (blk[2] shr 16) and $FF]; + blk[1]:= blk[1] xor s_box[((blk[2] shr 24) and $FF) + 256]; + blk[2]:= RRot32(blk[2], 24); + blk[0]:= blk[0] xor s_box[ blk[3] and $FF]; + blk[0]:= blk[0] + s_box[((blk[3] shr 8) and $FF) + 256]; + blk[1]:= blk[1] + s_box[ (blk[3] shr 16) and $FF]; + blk[2]:= blk[2] xor s_box[((blk[3] shr 24) and $FF) + 256]; + blk[3]:= RRot32(blk[3], 24); + blk[1]:= blk[1] xor s_box[ blk[0] and $FF]; + blk[1]:= blk[1] + s_box[((blk[0] shr 8) and $FF) + 256]; + blk[2]:= blk[2] + s_box[ (blk[0] shr 16) and $FF]; + blk[3]:= blk[3] xor s_box[((blk[0] shr 24) and $FF) + 256]; + blk[0]:= RRot32(blk[0], 24); blk[0]:= blk[0] + blk[3]; + blk[2]:= blk[2] xor s_box[ blk[1] and $FF]; + blk[2]:= blk[2] + s_box[((blk[1] shr 8) and $FF) + 256]; + blk[3]:= blk[3] + s_box[ (blk[1] shr 16) and $FF]; + blk[0]:= blk[0] xor s_box[((blk[1] shr 24) and $FF) + 256]; + blk[1]:= RRot32(blk[1], 24); blk[1]:= blk[1] + blk[2]; + blk[3]:= blk[3] xor s_box[ blk[2] and $FF]; + blk[3]:= blk[3] + s_box[((blk[2] shr 8) and $FF) + 256]; + blk[0]:= blk[0] + s_box[ (blk[2] shr 16) and $FF]; + blk[1]:= blk[1] xor s_box[((blk[2] shr 24) and $FF) + 256]; + blk[2]:= RRot32(blk[2], 24); + blk[0]:= blk[0] xor s_box[ blk[3] and $FF]; + blk[0]:= blk[0] + s_box[((blk[3] shr 8) and $FF) + 256]; + blk[1]:= blk[1] + s_box[ (blk[3] shr 16) and $FF]; + blk[2]:= blk[2] xor s_box[((blk[3] shr 24) and $FF) + 256]; + blk[3]:= RRot32(blk[3], 24); + m:= blk[0] + KeyData[4]; + r:= LRot32(blk[0],13) * KeyData[5]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= LRot32(blk[0],13); + blk[1]:= blk[1] + l; + blk[2]:= blk[2] + m; + blk[3]:= blk[3] xor r; + m:= blk[1] + KeyData[6]; + r:= LRot32(blk[1],13) * KeyData[7]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= LRot32(blk[1],13); + blk[2]:= blk[2] + l; + blk[3]:= blk[3] + m; + blk[0]:= blk[0] xor r; + m:= blk[2] + KeyData[8]; + r:= LRot32(blk[2],13) * KeyData[9]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= LRot32(blk[2],13); + blk[3]:= blk[3] + l; + blk[0]:= blk[0] + m; + blk[1]:= blk[1] xor r; + m:= blk[3] + KeyData[10]; + r:= LRot32(blk[3],13) * KeyData[11]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= LRot32(blk[3],13); + blk[0]:= blk[0] + l; + blk[1]:= blk[1] + m; + blk[2]:= blk[2] xor r; + m:= blk[0] + KeyData[12]; + r:= LRot32(blk[0],13) * KeyData[13]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= LRot32(blk[0],13); + blk[1]:= blk[1] + l; + blk[2]:= blk[2] + m; + blk[3]:= blk[3] xor r; + m:= blk[1] + KeyData[14]; + r:= LRot32(blk[1],13) * KeyData[15]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= LRot32(blk[1],13); + blk[2]:= blk[2] + l; + blk[3]:= blk[3] + m; + blk[0]:= blk[0] xor r; + m:= blk[2] + KeyData[16]; + r:= LRot32(blk[2],13) * KeyData[17]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= LRot32(blk[2],13); + blk[3]:= blk[3] + l; + blk[0]:= blk[0] + m; + blk[1]:= blk[1] xor r; + m:= blk[3] + KeyData[18]; + r:= LRot32(blk[3],13) * KeyData[19]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= LRot32(blk[3],13); + blk[0]:= blk[0] + l; + blk[1]:= blk[1] + m; + blk[2]:= blk[2] xor r; + m:= blk[0] + KeyData[20]; + r:= LRot32(blk[0],13) * KeyData[21]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= LRot32(blk[0],13); + blk[3]:= blk[3] + l; + blk[2]:= blk[2] + m; + blk[1]:= blk[1] xor r; + m:= blk[1] + KeyData[22]; + r:= LRot32(blk[1],13) * KeyData[23]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= LRot32(blk[1],13); + blk[0]:= blk[0] + l; + blk[3]:= blk[3] + m; + blk[2]:= blk[2] xor r; + m:= blk[2] + KeyData[24]; + r:= LRot32(blk[2],13) * KeyData[25]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= LRot32(blk[2],13); + blk[1]:= blk[1] + l; + blk[0]:= blk[0] + m; + blk[3]:= blk[3] xor r; + m:= blk[3] + KeyData[26]; + r:= LRot32(blk[3],13) * KeyData[27]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= LRot32(blk[3],13); + blk[2]:= blk[2] + l; + blk[1]:= blk[1] + m; + blk[0]:= blk[0] xor r; + m:= blk[0] + KeyData[28]; + r:= LRot32(blk[0],13) * KeyData[29]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= LRot32(blk[0],13); + blk[3]:= blk[3] + l; + blk[2]:= blk[2] + m; + blk[1]:= blk[1] xor r; + m:= blk[1] + KeyData[30]; + r:= LRot32(blk[1],13) * KeyData[31]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= LRot32(blk[1],13); + blk[0]:= blk[0] + l; + blk[3]:= blk[3] + m; + blk[2]:= blk[2] xor r; + m:= blk[2] + KeyData[32]; + r:= LRot32(blk[2],13) * KeyData[33]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= LRot32(blk[2],13); + blk[1]:= blk[1] + l; + blk[0]:= blk[0] + m; + blk[3]:= blk[3] xor r; + m:= blk[3] + KeyData[34]; + r:= LRot32(blk[3],13) * KeyData[35]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= LRot32(blk[3],13); + blk[2]:= blk[2] + l; + blk[1]:= blk[1] + m; + blk[0]:= blk[0] xor r; + blk[1]:= blk[1] xor s_box[ (blk[0] and $FF) + 256]; + blk[2]:= blk[2] - s_box[ (blk[0] shr 24) and $FF]; + blk[3]:= blk[3] - s_box[((blk[0] shr 16) and $FF) + 256]; + blk[3]:= blk[3] xor s_box[ (blk[0] shr 8) and $FF]; + blk[0]:= LRot32(blk[0], 24); + blk[2]:= blk[2] xor s_box[ (blk[1] and $FF) + 256]; + blk[3]:= blk[3] - s_box[ (blk[1] shr 24) and $FF]; + blk[0]:= blk[0] - s_box[((blk[1] shr 16) and $FF) + 256]; + blk[0]:= blk[0] xor s_box[ (blk[1] shr 8) and $FF]; + blk[1]:= LRot32(blk[1], 24); blk[2]:= blk[2] - blk[1]; + blk[3]:= blk[3] xor s_box[ (blk[2] and $FF) + 256]; + blk[0]:= blk[0] - s_box[ (blk[2] shr 24) and $FF]; + blk[1]:= blk[1] - s_box[((blk[2] shr 16) and $FF) + 256]; + blk[1]:= blk[1] xor s_box[ (blk[2] shr 8) and $FF]; + blk[2]:= LRot32(blk[2], 24); blk[3]:= blk[3] - blk[0]; + blk[0]:= blk[0] xor s_box[ (blk[3] and $FF) + 256]; + blk[1]:= blk[1] - s_box[ (blk[3] shr 24) and $FF]; + blk[2]:= blk[2] - s_box[((blk[3] shr 16) and $FF) + 256]; + blk[2]:= blk[2] xor s_box[ (blk[3] shr 8) and $FF]; + blk[3]:= LRot32(blk[3], 24); + blk[1]:= blk[1] xor s_box[ (blk[0] and $FF) + 256]; + blk[2]:= blk[2] - s_box[ (blk[0] shr 24) and $FF]; + blk[3]:= blk[3] - s_box[((blk[0] shr 16) and $FF) + 256]; + blk[3]:= blk[3] xor s_box[ (blk[0] shr 8) and $FF]; + blk[0]:= LRot32(blk[0], 24); + blk[2]:= blk[2] xor s_box[ (blk[1] and $FF) + 256]; + blk[3]:= blk[3] - s_box[ (blk[1] shr 24) and $FF]; + blk[0]:= blk[0] - s_box[((blk[1] shr 16) and $FF) + 256]; + blk[0]:= blk[0] xor s_box[ (blk[1] shr 8) and $FF]; + blk[1]:= LRot32(blk[1], 24); blk[2]:= blk[2] - blk[1]; + blk[3]:= blk[3] xor s_box[ (blk[2] and $FF) + 256]; + blk[0]:= blk[0] - s_box[ (blk[2] shr 24) and $FF]; + blk[1]:= blk[1] - s_box[((blk[2] shr 16) and $FF) + 256]; + blk[1]:= blk[1] xor s_box[ (blk[2] shr 8) and $FF]; + blk[2]:= LRot32(blk[2], 24); blk[3]:= blk[3] - blk[0]; + blk[0]:= blk[0] xor s_box[ (blk[3] and $FF) + 256]; + blk[1]:= blk[1] - s_box[ (blk[3] shr 24) and $FF]; + blk[2]:= blk[2] - s_box[((blk[3] shr 16) and $FF) + 256]; + blk[2]:= blk[2] xor s_box[ (blk[3] shr 8) and $FF]; + blk[3]:= LRot32(blk[3], 24); + blk[0]:= blk[0] - KeyData[36]; blk[1]:= blk[1] - KeyData[37]; + blk[2]:= blk[2] - KeyData[38]; blk[3]:= blk[3] - KeyData[39]; + + PDWord(@OutData)^:= Blk[0]; + PDWord(longword(@OutData)+4)^:= Blk[1]; + PDWord(longword(@OutData)+8)^:= Blk[2]; + PDWord(longword(@OutData)+12)^:= Blk[3]; +end; + +procedure Tmars.DecryptECB(const InData; var OutData); +var + l, m, r, t: DWord; + blk: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + Blk[0]:= PDWord(@InData)^; + Blk[1]:= PDWord(longword(@InData)+4)^; + Blk[2]:= PDWord(longword(@InData)+8)^; + Blk[3]:= PDWord(longword(@InData)+12)^; + + blk[0]:= blk[0] + KeyData[36]; blk[1]:= blk[1] + KeyData[37]; + blk[2]:= blk[2] + KeyData[38]; blk[3]:= blk[3] + KeyData[39]; + blk[3]:= RRot32(blk[3], 24); + blk[2]:= blk[2] xor s_box[ (blk[3] shr 8) and $FF]; + blk[2]:= blk[2] + s_box[((blk[3] shr 16) and $FF) + 256]; + blk[1]:= blk[1] + s_box[ (blk[3] shr 24) and $FF]; + blk[0]:= blk[0] xor s_box[ (blk[3] and $FF) + 256]; + blk[3]:= blk[3] + blk[0]; blk[2]:= RRot32(blk[2], 24); + blk[1]:= blk[1] xor s_box[ (blk[2] shr 8) and $FF]; + blk[1]:= blk[1] + s_box[((blk[2] shr 16) and $FF) + 256]; + blk[0]:= blk[0] + s_box[ (blk[2] shr 24) and $FF]; + blk[3]:= blk[3] xor s_box[ (blk[2] and $FF) + 256]; + blk[2]:= blk[2] + blk[1]; blk[1]:= RRot32(blk[1], 24); + blk[0]:= blk[0] xor s_box[ (blk[1] shr 8) and $FF]; + blk[0]:= blk[0] + s_box[((blk[1] shr 16) and $FF) + 256]; + blk[3]:= blk[3] + s_box[ (blk[1] shr 24) and $FF]; + blk[2]:= blk[2] xor s_box[ (blk[1] and $FF) + 256]; + blk[0]:= RRot32(blk[0], 24); + blk[3]:= blk[3] xor s_box[ (blk[0] shr 8) and $FF]; + blk[3]:= blk[3] + s_box[((blk[0] shr 16) and $FF) + 256]; + blk[2]:= blk[2] + s_box[ (blk[0] shr 24) and $FF]; + blk[1]:= blk[1] xor s_box[ (blk[0] and $FF) + 256]; + blk[3]:= RRot32(blk[3], 24); + blk[2]:= blk[2] xor s_box[ (blk[3] shr 8) and $FF]; + blk[2]:= blk[2] + s_box[((blk[3] shr 16) and $FF) + 256]; + blk[1]:= blk[1] + s_box[ (blk[3] shr 24) and $FF]; + blk[0]:= blk[0] xor s_box[ (blk[3] and $FF) + 256]; + blk[3]:= blk[3] + blk[0]; blk[2]:= RRot32(blk[2], 24); + blk[1]:= blk[1] xor s_box[ (blk[2] shr 8) and $FF]; + blk[1]:= blk[1] + s_box[((blk[2] shr 16) and $FF) + 256]; + blk[0]:= blk[0] + s_box[ (blk[2] shr 24) and $FF]; + blk[3]:= blk[3] xor s_box[ (blk[2] and $FF) + 256]; + blk[2]:= blk[2] + blk[1]; blk[1]:= RRot32(blk[1], 24); + blk[0]:= blk[0] xor s_box[ (blk[1] shr 8) and $FF]; + blk[0]:= blk[0] + s_box[((blk[1] shr 16) and $FF) + 256]; + blk[3]:= blk[3] + s_box[ (blk[1] shr 24) and $FF]; + blk[2]:= blk[2] xor s_box[ (blk[1] and $FF) + 256]; + blk[0]:= RRot32(blk[0], 24); + blk[3]:= blk[3] xor s_box[ (blk[0] shr 8) and $FF]; + blk[3]:= blk[3] + s_box[((blk[0] shr 16) and $FF) + 256]; + blk[2]:= blk[2] + s_box[ (blk[0] shr 24) and $FF]; + blk[1]:= blk[1] xor s_box[ (blk[0] and $FF) + 256]; + blk[3]:= RRot32(blk[3],13); + m:= blk[3] + KeyData[34]; + r:= LRot32(blk[3],13) * KeyData[35]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= blk[2] - l; + blk[1]:= blk[1] - m; + blk[0]:= blk[0] xor r; + blk[2]:= RRot32(blk[2],13); + m:= blk[2] + KeyData[32]; + r:= LRot32(blk[2],13) * KeyData[33]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= blk[1] - l; + blk[0]:= blk[0] - m; + blk[3]:= blk[3] xor r; + blk[1]:= RRot32(blk[1],13); + m:= blk[1] + KeyData[30]; + r:= LRot32(blk[1],13) * KeyData[31]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= blk[0] - l; + blk[3]:= blk[3] - m; + blk[2]:= blk[2] xor r; + blk[0]:= RRot32(blk[0],13); + m:= blk[0] + KeyData[28]; + r:= LRot32(blk[0],13) * KeyData[29]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= blk[3] - l; + blk[2]:= blk[2] - m; + blk[1]:= blk[1] xor r; + blk[3]:= RRot32(blk[3],13); + m:= blk[3] + KeyData[26]; + r:= LRot32(blk[3],13) * KeyData[27]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= blk[2] - l; + blk[1]:= blk[1] - m; + blk[0]:= blk[0] xor r; + blk[2]:= RRot32(blk[2],13); + m:= blk[2] + KeyData[24]; + r:= LRot32(blk[2],13) * KeyData[25]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= blk[1] - l; + blk[0]:= blk[0] - m; + blk[3]:= blk[3] xor r; + blk[1]:= RRot32(blk[1],13); + m:= blk[1] + KeyData[22]; + r:= LRot32(blk[1],13) * KeyData[23]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= blk[0] - l; + blk[3]:= blk[3] - m; + blk[2]:= blk[2] xor r; + blk[0]:= RRot32(blk[0],13); + m:= blk[0] + KeyData[20]; + r:= LRot32(blk[0],13) * KeyData[21]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= blk[3] - l; + blk[2]:= blk[2] - m; + blk[1]:= blk[1] xor r; + blk[3]:= RRot32(blk[3],13); + m:= blk[3] + KeyData[18]; + r:= LRot32(blk[3],13) * KeyData[19]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= blk[0] - l; + blk[1]:= blk[1] - m; + blk[2]:= blk[2] xor r; + blk[2]:= RRot32(blk[2],13); + m:= blk[2] + KeyData[16]; + r:= LRot32(blk[2],13) * KeyData[17]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= blk[3] - l; + blk[0]:= blk[0] - m; + blk[1]:= blk[1] xor r; + blk[1]:= RRot32(blk[1],13); + m:= blk[1] + KeyData[14]; + r:= LRot32(blk[1],13) * KeyData[15]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= blk[2] - l; + blk[3]:= blk[3] - m; + blk[0]:= blk[0] xor r; + blk[0]:= RRot32(blk[0],13); + m:= blk[0] + KeyData[12]; + r:= LRot32(blk[0],13) * KeyData[13]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= blk[1] - l; + blk[2]:= blk[2] - m; + blk[3]:= blk[3] xor r; + blk[3]:= RRot32(blk[3],13); + m:= blk[3] + KeyData[10]; + r:= LRot32(blk[3],13) * KeyData[11]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[0]:= blk[0] - l; + blk[1]:= blk[1] - m; + blk[2]:= blk[2] xor r; + blk[2]:= RRot32(blk[2],13); + m:= blk[2] + KeyData[8]; + r:= LRot32(blk[2],13) * KeyData[9]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[3]:= blk[3] - l; + blk[0]:= blk[0] - m; + blk[1]:= blk[1] xor r; + blk[1]:= RRot32(blk[1],13); + m:= blk[1] + KeyData[6]; + r:= LRot32(blk[1],13) * KeyData[7]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[2]:= blk[2] - l; + blk[3]:= blk[3] - m; + blk[0]:= blk[0] xor r; + blk[0]:= RRot32(blk[0],13); + m:= blk[0] + KeyData[4]; + r:= LRot32(blk[0],13) * KeyData[5]; + l:= s_box[m and $1FF]; r:= LRot32(r,5); + t:= r and $1f; m:= LRot32(m,t); + l:= l xor r; r:= LRot32(r,5); l:= l xor r; + t:= r and $1f; l:= LRot32(l,t); + blk[1]:= blk[1] - l; + blk[2]:= blk[2] - m; + blk[3]:= blk[3] xor r; + blk[3]:= LRot32(blk[3], 24); + blk[2]:= blk[2] xor s_box[((blk[3] shr 24) and $FF) + 256]; + blk[1]:= blk[1] - s_box[ (blk[3] shr 16) and $FF]; + blk[0]:= blk[0] - s_box[((blk[3] shr 8) and $FF) + 256]; + blk[0]:= blk[0] xor s_box[ blk[3] and $FF]; + blk[2]:= LRot32(blk[2], 24); + blk[1]:= blk[1] xor s_box[((blk[2] shr 24) and $FF) + 256]; + blk[0]:= blk[0] - s_box[ (blk[2] shr 16) and $FF]; + blk[3]:= blk[3] - s_box[((blk[2] shr 8) and $FF) + 256]; + blk[3]:= blk[3] xor s_box[ blk[2] and $FF]; + blk[1]:= blk[1] - blk[2]; blk[1]:= LRot32(blk[1], 24); + blk[0]:= blk[0] xor s_box[((blk[1] shr 24) and $FF) + 256]; + blk[3]:= blk[3] - s_box[ (blk[1] shr 16) and $FF]; + blk[2]:= blk[2] - s_box[((blk[1] shr 8) and $FF) + 256]; + blk[2]:= blk[2] xor s_box[ blk[1] and $FF]; + blk[0]:= blk[0] - blk[3]; blk[0]:= LRot32(blk[0], 24); + blk[3]:= blk[3] xor s_box[((blk[0] shr 24) and $FF) + 256]; + blk[2]:= blk[2] - s_box[ (blk[0] shr 16) and $FF]; + blk[1]:= blk[1] - s_box[((blk[0] shr 8) and $FF) + 256]; + blk[1]:= blk[1] xor s_box[ blk[0] and $FF]; + blk[3]:= LRot32(blk[3], 24); + blk[2]:= blk[2] xor s_box[((blk[3] shr 24) and $FF) + 256]; + blk[1]:= blk[1] - s_box[ (blk[3] shr 16) and $FF]; + blk[0]:= blk[0] - s_box[((blk[3] shr 8) and $FF) + 256]; + blk[0]:= blk[0] xor s_box[ blk[3] and $FF]; + blk[2]:= LRot32(blk[2], 24); + blk[1]:= blk[1] xor s_box[((blk[2] shr 24) and $FF) + 256]; + blk[0]:= blk[0] - s_box[ (blk[2] shr 16) and $FF]; + blk[3]:= blk[3] - s_box[((blk[2] shr 8) and $FF) + 256]; + blk[3]:= blk[3] xor s_box[ blk[2] and $FF]; + blk[1]:= blk[1] - blk[2]; blk[1]:= LRot32(blk[1], 24); + blk[0]:= blk[0] xor s_box[((blk[1] shr 24) and $FF) + 256]; + blk[3]:= blk[3] - s_box[ (blk[1] shr 16) and $FF]; + blk[2]:= blk[2] - s_box[((blk[1] shr 8) and $FF) + 256]; + blk[2]:= blk[2] xor s_box[ blk[1] and $FF]; + blk[0]:= blk[0] - blk[3]; blk[0]:= LRot32(blk[0], 24); + blk[3]:= blk[3] xor s_box[((blk[0] shr 24) and $FF) + 256]; + blk[2]:= blk[2] - s_box[ (blk[0] shr 16) and $FF]; + blk[1]:= blk[1] - s_box[((blk[0] shr 8) and $FF) + 256]; + blk[1]:= blk[1] xor s_box[ blk[0] and $FF]; + blk[0]:= blk[0] - KeyData[0]; blk[1]:= blk[1] - KeyData[1]; + blk[2]:= blk[2] - KeyData[2]; blk[3]:= blk[3] - KeyData[3]; + + PDWord(@OutData)^:= Blk[0]; + PDWord(longword(@OutData)+4)^:= Blk[1]; + PDWord(longword(@OutData)+8)^:= Blk[2]; + PDWord(longword(@OutData)+12)^:= Blk[3]; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TRC6.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewRC6; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +procedure Trc6.InitKey(const Key; Size: longword); +var + xKeyD: array[0..63] of DWord; + i, j, k, xKeyLen: longword; + A, B: DWord; +begin +burn; + Size:= Size div 8; + FillChar(xKeyD,Sizeof(xKeyD),0); + Move(Key,xKeyD,Size); + xKeyLen:= Size div 4; + if (Size mod 4)<> 0 then + Inc(xKeyLen); + Move(SBoxRC6,KeyData,((NUMROUNDSRC6*2)+4)*4); + i:= 0; j:= 0; + A:= 0; B:= 0; + if xKeyLen> ((NUMROUNDSRC6*2)+4) then + k:= xKeyLen*3 + else + k:= ((NUMROUNDSRC6*2)+4)*3; + for k:= 1 to k do + begin + A:= LRot32(KeyData[i]+A+B,3); + KeyData[i]:= A; + B:= LRot32(xKeyD[j]+A+B,A+B); + xKeyD[j]:= B; + i:= (i+1) mod ((NUMROUNDSRC6*2)+4); + j:= (j+1) mod xKeyLen; + end; + FillChar(xKeyD,Sizeof(xKeyD),0); +end; + +procedure Trc6.Burn; +begin + FillChar(KeyData,Sizeof(KeyData),$FF); + inherited Burn; +end; + +procedure Trc6.EncryptECB(const InData; var OutData); +var + x0, x1, x2, x3: DWord; + u, t: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + x0:= PDword(@InData)^; + x1:= PDword(longword(@InData)+4)^; + x2:= PDword(longword(@InData)+8)^; + x3:= PDword(longword(@InData)+12)^; + x1:= x1 + KeyData[0]; + x3:= x3 + KeyData[1]; + for i:= 1 to NUMROUNDSRC6 do + begin + t:= Lrot32(x1 * (2*x1 + 1),5); + u:= Lrot32(x3 * (2*x3 + 1),5); + x0:= Lrot32(x0 xor t,u) + KeyData[2*i]; + x2:= Lrot32(x2 xor u,t) + KeyData[2*i+1]; + t:= x0; x0:= x1; x1:= x2; x2:= x3; x3:= t; + end; + x0:= x0 + KeyData[(2*NUMROUNDSRC6)+2]; + x2:= x2 + KeyData[(2*NUMROUNDSRC6)+3]; + PDword(@OutData)^:= x0; + PDword(longword(@OutData)+4)^:= x1; + PDword(longword(@OutData)+8)^:= x2; + PDword(longword(@OutData)+12)^:= x3; +end; + +procedure Trc6.DecryptECB(const InData; var OutData); +var + x0, x1, x2, x3: DWord; + u, t: DWord; + i: longword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + x0:= PDword(@InData)^; + x1:= PDword(longword(@InData)+4)^; + x2:= PDword(longword(@InData)+8)^; + x3:= PDword(longword(@InData)+12)^; + x2:= x2 - KeyData[(2*NUMROUNDSRC6)+3]; + x0:= x0 - KeyData[(2*NUMROUNDSRC6)+2]; + for i:= NUMROUNDSRC6 downto 1 do + begin + t:= x0; x0:= x3; x3:= x2; x2:= x1; x1:= t; + u:= Lrot32(x3 * (2*x3 + 1),5); + t:= Lrot32(x1 * (2*x1 + 1),5); + x2:= Rrot32(x2 - KeyData[2*i+1],t) xor u; + x0:= Rrot32(x0 - KeyData[2*i],u) xor t; + end; + x3:= x3 - KeyData[1]; + x1:= x1 - KeyData[0]; + PDword(@OutData)^:= x0; + PDword(longword(@OutData)+4)^:= x1; + PDword(longword(@OutData)+8)^:= x2; + PDword(longword(@OutData)+12)^:= x3; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TRijndael.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewRijndael; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +procedure InvMixColumn(a: PByteArray; BC: byte); +var + j: longword; +begin + for j:= 0 to (BC-1) do + PDWord(@(a^[j*4]))^:= PDWord(@U1[a^[j*4+0]])^ xor + PDWord(@U2[a^[j*4+1]])^ xor + PDWord(@U3[a^[j*4+2]])^ xor + PDWord(@U4[a^[j*4+3]])^; +end; + +procedure Trijndael.InitKey(const Key; Size: longword); +var + KC, ROUNDS, j, r, t, rconpointer: longword; + tk: array[0..MAXKC-1,0..3] of byte; +begin +burn; + Size:= Size div 8; + + FillChar(tk,Sizeof(tk),0); + Move(Key,tk,Size); + if Size<= 16 then + begin + KC:= 4; + Rounds:= 10; + end + else if Size<= 24 then + begin + KC:= 6; + Rounds:= 12; + end + else + begin + KC:= 8; + Rounds:= 14; + end; + numrounds:= rounds; + r:= 0; + t:= 0; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BCRJ) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BCRJ then + begin + t:= 0; + Inc(r); + end; + end; + rconpointer:= 0; + while (r< (rounds+1)) do + begin + tk[0,0]:= tk[0,0] xor S[tk[KC-1,1]]; + tk[0,1]:= tk[0,1] xor S[tk[KC-1,2]]; + tk[0,2]:= tk[0,2] xor S[tk[KC-1,3]]; + tk[0,3]:= tk[0,3] xor S[tk[KC-1,0]]; + tk[0,0]:= tk[0,0] xor rcon[rconpointer]; + Inc(rconpointer); + if KC<> 8 then + begin + for j:= 1 to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end + else + begin + for j:= 1 to ((KC div 2)-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + tk[KC div 2,0]:= tk[KC div 2,0] xor S[tk[KC div 2 - 1,0]]; + tk[KC div 2,1]:= tk[KC div 2,1] xor S[tk[KC div 2 - 1,1]]; + tk[KC div 2,2]:= tk[KC div 2,2] xor S[tk[KC div 2 - 1,2]]; + tk[KC div 2,3]:= tk[KC div 2,3] xor S[tk[KC div 2 - 1,3]]; + for j:= ((KC div 2) + 1) to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BCRJ) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BCRJ then + begin + Inc(r); + t:= 0; + end; + end; + end; + Move(rk,drk,Sizeof(rk)); + for r:= 1 to (numrounds-1) do + InvMixColumn(@drk[r],BCRJ); +end; + +procedure Trijndael.Burn; +begin + numrounds:= 0; + FillChar(rk,Sizeof(rk),0); + FillChar(drk,Sizeof(drk),0); + inherited Burn; +end; + +procedure Trijndael.EncryptECB(const InData; var OutData); +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + PDword(@a[0,0])^:= PDword(@InData)^; + PDword(@a[1,0])^:= PDword(dword(@InData)+4)^; + PDword(@a[2,0])^:= PDword(dword(@InData)+8)^; + PDword(@a[3,0])^:= PDword(dword(@InData)+12)^; + for r:= 0 to (numrounds-2) do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[r,3]; + PDWord(@a[0])^:= PDWord(@T1[tempb[0,0]])^ xor + PDWord(@T2[tempb[1,1]])^ xor + PDWord(@T3[tempb[2,2]])^ xor + PDWord(@T4[tempb[3,3]])^; + PDWord(@a[1])^:= PDWord(@T1[tempb[1,0]])^ xor + PDWord(@T2[tempb[2,1]])^ xor + PDWord(@T3[tempb[3,2]])^ xor + PDWord(@T4[tempb[0,3]])^; + PDWord(@a[2])^:= PDWord(@T1[tempb[2,0]])^ xor + PDWord(@T2[tempb[3,1]])^ xor + PDWord(@T3[tempb[0,2]])^ xor + PDWord(@T4[tempb[1,3]])^; + PDWord(@a[3])^:= PDWord(@T1[tempb[3,0]])^ xor + PDWord(@T2[tempb[0,1]])^ xor + PDWord(@T3[tempb[1,2]])^ xor + PDWord(@T4[tempb[2,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[numrounds-1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[numrounds-1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[numrounds-1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[numrounds-1,3]; + a[0,0]:= T1[tempb[0,0],1]; + a[0,1]:= T1[tempb[1,1],1]; + a[0,2]:= T1[tempb[2,2],1]; + a[0,3]:= T1[tempb[3,3],1]; + a[1,0]:= T1[tempb[1,0],1]; + a[1,1]:= T1[tempb[2,1],1]; + a[1,2]:= T1[tempb[3,2],1]; + a[1,3]:= T1[tempb[0,3],1]; + a[2,0]:= T1[tempb[2,0],1]; + a[2,1]:= T1[tempb[3,1],1]; + a[2,2]:= T1[tempb[0,2],1]; + a[2,3]:= T1[tempb[1,3],1]; + a[3,0]:= T1[tempb[3,0],1]; + a[3,1]:= T1[tempb[0,1],1]; + a[3,2]:= T1[tempb[1,2],1]; + a[3,3]:= T1[tempb[2,3],1]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor rk[numrounds,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor rk[numrounds,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor rk[numrounds,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor rk[numrounds,3]; + + PDword(@OutData)^:= PDword(@a[0,0])^; + PDword(dword(@OutData)+4)^:= PDword(@a[1,0])^; + PDword(dword(@OutData)+8)^:= PDword(@a[2,0])^; + PDword(dword(@OutData)+12)^:= PDword(@a[3,0])^; +end; + +procedure Trijndael.DecryptECB(const InData; var OutData); +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + PDword(@a[0,0])^:= PDword(@InData)^; + PDword(@a[1,0])^:= PDword(dword(@InData)+4)^; + PDword(@a[2,0])^:= PDword(dword(@InData)+8)^; + PDword(@a[3,0])^:= PDword(dword(@InData)+12)^; + for r:= NumRounds downto 2 do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[r,3]; + PDWord(@a[0])^:= PDWord(@T5[tempb[0,0]])^ xor + PDWord(@T6[tempb[3,1]])^ xor + PDWord(@T7[tempb[2,2]])^ xor + PDWord(@T8[tempb[1,3]])^; + PDWord(@a[1])^:= PDWord(@T5[tempb[1,0]])^ xor + PDWord(@T6[tempb[0,1]])^ xor + PDWord(@T7[tempb[3,2]])^ xor + PDWord(@T8[tempb[2,3]])^; + PDWord(@a[2])^:= PDWord(@T5[tempb[2,0]])^ xor + PDWord(@T6[tempb[1,1]])^ xor + PDWord(@T7[tempb[0,2]])^ xor + PDWord(@T8[tempb[3,3]])^; + PDWord(@a[3])^:= PDWord(@T5[tempb[3,0]])^ xor + PDWord(@T6[tempb[2,1]])^ xor + PDWord(@T7[tempb[1,2]])^ xor + PDWord(@T8[tempb[0,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[1,3]; + a[0,0]:= S5[tempb[0,0]]; + a[0,1]:= S5[tempb[3,1]]; + a[0,2]:= S5[tempb[2,2]]; + a[0,3]:= S5[tempb[1,3]]; + a[1,0]:= S5[tempb[1,0]]; + a[1,1]:= S5[tempb[0,1]]; + a[1,2]:= S5[tempb[3,2]]; + a[1,3]:= S5[tempb[2,3]]; + a[2,0]:= S5[tempb[2,0]]; + a[2,1]:= S5[tempb[1,1]]; + a[2,2]:= S5[tempb[0,2]]; + a[2,3]:= S5[tempb[3,3]]; + a[3,0]:= S5[tempb[3,0]]; + a[3,1]:= S5[tempb[2,1]]; + a[3,2]:= S5[tempb[1,2]]; + a[3,3]:= S5[tempb[0,3]]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor drk[0,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor drk[0,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor drk[0,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor drk[0,3]; + PDword(@OutData)^:= PDword(@a[0,0])^; + PDword(dword(@OutData)+4)^:= PDword(@a[1,0])^; + PDword(dword(@OutData)+8)^:= PDword(@a[2,0])^; + PDword(dword(@OutData)+12)^:= PDword(@a[3,0])^; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TSerpent.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewSerpent; +begin +New(Result, Create); + +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +procedure Tserpent.InitKey(const Key; Size: longword); +var + kp: array[0..139] of dword; + i, n: integer; + t, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14, t15, t16, t17: dword; + a, b, c, d: dword; +begin +burn; + FillChar(kp,256 div 8,0); + Move(Key,kp,Size div 8); + if Size < 256 then + begin + i:= Size div 32; + t:= 1 shl (Size mod 32); + kp[i]:= (kp[i] and (t - 1)) or t; + end; + for i:= 8 to 139 do + begin + t:= kp[i - 8] xor kp[i - 5] xor kp[i - 3] xor kp[i - 1] xor $9e3779b9 xor longword(i-8); + kp[i]:= (t shl 11) or (t shr 21); + end; + for i:= 0 to 3 do + begin + n:= i*32; + a:= kp[n + 4*0 + 8]; b:= kp[n + 4*0 + 9]; c:= kp[n + 4*0 + 10]; d:= kp[n + 4*0 + 11]; + t1:= a xor c; t2:= a or d; t3:= a and b; t4:= a and d; t5:= b or t4; t6:= t1 and t2; kp[ 9+n]:= t5 xor t6; t8:= b xor d; t9:= c or t3; t10:= t6 xor t8; kp[ 11+n]:= t9 xor t10; t12:= c xor t3; t13:= t2 and kp[ 11+n]; kp[ 10+n]:= t12 xor t13; t15:= not kp[ 10+n]; t16:= t2 xor t3; t17:= kp[ 9+n] and t15; kp[ 8+n]:= t16 xor t17; + a:= kp[n + 4*1 + 8]; b:= kp[n + 4*1 + 9]; c:= kp[n + 4*1 + 10]; d:= kp[n + 4*1 + 11]; + t1:= not a; t2:= b xor d; t3:= c and t1; kp[ 12+n]:= t2 xor t3; t5:= c xor t1; t6:= c xor kp[ 12+n]; t7:= b and t6; kp[ 15+n]:= t5 xor t7; t9:= d or t7; t10:= kp[ 12+n] or t5; t11:= t9 and t10; kp[ 14+n]:= a xor t11; t13:= d or t1; t14:= t2 xor kp[ 15+n]; t15:= kp[ 14+n] xor t13; kp[ 13+n]:= t14 xor t15; + a:= kp[n + 4*2 + 8]; b:= kp[n + 4*2 + 9]; c:= kp[n + 4*2 + 10]; d:= kp[n + 4*2 + 11]; + t1:= a xor d; t2:= b xor d; t3:= a and b; t4:= not c; t5:= t2 xor t3; kp[ 18+n]:= t4 xor t5; t7:= a xor t2; t8:= b or t4; t9:= d or kp[ 18+n]; t10:= t7 and t9; kp[ 17+n]:= t8 xor t10; t12:= c xor d; t13:= t1 or t2; t14:= kp[ 17+n] xor t12; kp[ 19+n]:= t13 xor t14; t16:= t1 or kp[ 18+n]; t17:= t8 xor t14; kp[ 16+n]:= t16 xor t17; + a:= kp[n + 4*3 + 8]; b:= kp[n + 4*3 + 9]; c:= kp[n + 4*3 + 10]; d:= kp[n + 4*3 + 11]; + t1:= b xor d; t2:= not t1; t3:= a or d; t4:= b xor c; kp[ 23+n]:= t3 xor t4; t6:= a xor b; t7:= a or t4; t8:= c and t6; t9:= t2 or t8; kp[ 20+n]:= t7 xor t9; t11:= a xor kp[ 23+n]; t12:= t1 and t6; t13:= kp[ 20+n] xor t11; kp[ 21+n]:= t12 xor t13; t15:= kp[ 20+n] or kp[ 21+n]; t16:= t3 and t15; kp[ 22+n]:= b xor t16; + a:= kp[n + 4*4 + 8]; b:= kp[n + 4*4 + 9]; c:= kp[n + 4*4 + 10]; d:= kp[n + 4*4 + 11]; + t1:= not c; t2:= b xor c; t3:= b or t1; t4:= d xor t3; t5:= a and t4; kp[ 27+n]:= t2 xor t5; t7:= a xor d; t8:= b xor t5; t9:= t2 or t8; kp[ 25+n]:= t7 xor t9; t11:= d and t3; t12:= t5 xor kp[ 25+n]; t13:= kp[ 27+n] and t12; kp[ 26+n]:= t11 xor t13; t15:= t1 or t4; t16:= t12 xor kp[ 26+n]; kp[ 24+n]:= t15 xor t16; + a:= kp[n + 4*5 + 8]; b:= kp[n + 4*5 + 9]; c:= kp[n + 4*5 + 10]; d:= kp[n + 4*5 + 11]; + t1:= a xor c; t2:= b or d; t3:= b xor c; t4:= not t3; t5:= a and d; kp[ 29+n]:= t4 xor t5; t7:= b or c; t8:= d xor t1; t9:= t7 and t8; kp[ 31+n]:= t2 xor t9; t11:= t1 and t7; t12:= t4 xor t8; t13:= kp[ 31+n] and t11; kp[ 28+n]:= t12 xor t13; t15:= t3 xor t11; t16:= kp[ 31+n] or t15; kp[ 30+n]:= t12 xor t16; + a:= kp[n + 4*6 + 8]; b:= kp[n + 4*6 + 9]; c:= kp[n + 4*6 + 10]; d:= kp[n + 4*6 + 11]; + t1:= not a; t2:= a xor b; t3:= a xor d; t4:= c xor t1; t5:= t2 or t3; kp[ 32+n]:= t4 xor t5; t7:= not d; t8:= kp[ 32+n] and t7; kp[ 33+n]:= t2 xor t8; t10:= b or kp[ 33+n]; t11:= c or kp[ 32+n]; t12:= t7 xor t10; kp[ 35+n]:= t11 xor t12; t14:= d or kp[ 33+n]; t15:= t1 xor t14; t16:= kp[ 32+n] or kp[ 35+n]; kp[ 34+n]:= t15 xor t16; + a:= kp[n + 4*7 + 8]; b:= kp[n + 4*7 + 9]; c:= kp[n + 4*7 + 10]; d:= kp[n + 4*7 + 11]; + t1:= not a; t2:= a xor d; t3:= a xor b; t4:= c xor t1; t5:= t2 or t3; kp[ 36+n]:= t4 xor t5; t7:= not kp[ 36+n]; t8:= b or t7; kp[ 39+n]:= t2 xor t8; t10:= a and kp[ 36+n]; t11:= b xor kp[ 39+n]; t12:= t8 and t11; kp[ 38+n]:= t10 xor t12; t14:= a or t7; t15:= t3 xor t14; t16:= kp[ 39+n] and kp[ 38+n]; kp[ 37+n]:= t15 xor t16; + end; + a:= kp[136]; b:= kp[137]; c:= kp[138]; d:= kp[139]; + t1:= a xor c; t2:= a or d; t3:= a and b; t4:= a and d; t5:= b or t4; t6:= t1 and t2; kp[137]:= t5 xor t6; t8:= b xor d; t9:= c or t3; t10:= t6 xor t8; kp[139]:= t9 xor t10; t12:= c xor t3; t13:= t2 and kp[139]; kp[138]:= t12 xor t13; t15:= not kp[138]; t16:= t2 xor t3; t17:= kp[137] and t15; kp[136]:= t16 xor t17; + Move(kp[8],l_key,Sizeof(l_key)); + FillChar(kp,Sizeof(kp),0); +end; + +procedure Tserpent.Burn; +begin + FillChar(l_key,Sizeof(l_key),0); + inherited Burn; +end; + +procedure Tserpent.EncryptECB(const InData; var OutData); +var + i: integer; + a, b, c, d, e, f, g, h: dword; + t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14, t15, t16, t17: dword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + + a:= PDWord(@InData)^; + b:= PDWord(longword(@InData)+4)^; + c:= PDWord(longword(@InData)+8)^; + d:= PDWord(longword(@InData)+12)^; + + i:= 0; + while i < 32 do + begin + a:= a xor l_key[4*(i)]; b:= b xor l_key[4*(i)+1]; c:= c xor l_key[4*(i)+2]; d:= d xor l_key[4*(i)+3]; + t1:= b xor d; t2:= not t1; t3:= a or d; t4:= b xor c; h:= t3 xor t4; t6:= a xor b; t7:= a or t4; t8:= c and t6; t9:= t2 or t8; e:= t7 xor t9; t11:= a xor h; t12:= t1 and t6; t13:= e xor t11; f:= t12 xor t13; t15:= e or f; t16:= t3 and t15; g:= b xor t16; + e:= (e shl 13) or (e shr 19); g:= (g shl 3) or (g shr 29); f:= f xor e xor g; h:= h xor g xor (e shl 3); f:= (f shl 1) or (f shr 31); h:= (h shl 7) or (h shr 25); e:= e xor f xor h; g:= g xor h xor (f shl 7); e:= (e shl 5) or (e shr 27); g:= (g shl 22) or (g shr 10); + e:= e xor l_key[4*(i+1)]; f:= f xor l_key[4*(i+1)+1]; g:= g xor l_key[4*(i+1)+2]; h:= h xor l_key[4*(i+1)+3]; + t1:= e xor h; t2:= f xor h; t3:= e and f; t4:= not g; t5:= t2 xor t3; c:= t4 xor t5; t7:= e xor t2; t8:= f or t4; t9:= h or c; t10:= t7 and t9; b:= t8 xor t10; t12:= g xor h; t13:= t1 or t2; t14:= b xor t12; d:= t13 xor t14; t16:= t1 or c; t17:= t8 xor t14; a:= t16 xor t17; + a:= (a shl 13) or (a shr 19); c:= (c shl 3) or (c shr 29); b:= b xor a xor c; d:= d xor c xor (a shl 3); b:= (b shl 1) or (b shr 31); d:= (d shl 7) or (d shr 25); a:= a xor b xor d; c:= c xor d xor (b shl 7); a:= (a shl 5) or (a shr 27); c:= (c shl 22) or (c shr 10); + a:= a xor l_key[4*(i+2)]; b:= b xor l_key[4*(i+2)+1]; c:= c xor l_key[4*(i+2)+2]; d:= d xor l_key[4*(i+2)+3]; + t1:= not a; t2:= b xor d; t3:= c and t1; e:= t2 xor t3; t5:= c xor t1; t6:= c xor e; t7:= b and t6; h:= t5 xor t7; t9:= d or t7; t10:= e or t5; t11:= t9 and t10; g:= a xor t11; t13:= d or t1; t14:= t2 xor h; t15:= g xor t13; f:= t14 xor t15; + e:= (e shl 13) or (e shr 19); g:= (g shl 3) or (g shr 29); f:= f xor e xor g; h:= h xor g xor (e shl 3); f:= (f shl 1) or (f shr 31); h:= (h shl 7) or (h shr 25); e:= e xor f xor h; g:= g xor h xor (f shl 7); e:= (e shl 5) or (e shr 27); g:= (g shl 22) or (g shr 10); + e:= e xor l_key[4*(i+3)]; f:= f xor l_key[4*(i+3)+1]; g:= g xor l_key[4*(i+3)+2]; h:= h xor l_key[4*(i+3)+3]; + t1:= e xor g; t2:= e or h; t3:= e and f; t4:= e and h; t5:= f or t4; t6:= t1 and t2; b:= t5 xor t6; t8:= f xor h; t9:= g or t3; t10:= t6 xor t8; d:= t9 xor t10; t12:= g xor t3; t13:= t2 and d; c:= t12 xor t13; t15:= not c; t16:= t2 xor t3; t17:= b and t15; a:= t16 xor t17; + a:= (a shl 13) or (a shr 19); c:= (c shl 3) or (c shr 29); b:= b xor a xor c; d:= d xor c xor (a shl 3); b:= (b shl 1) or (b shr 31); d:= (d shl 7) or (d shr 25); a:= a xor b xor d; c:= c xor d xor (b shl 7); a:= (a shl 5) or (a shr 27); c:= (c shl 22) or (c shr 10); + a:= a xor l_key[4*(i+4)]; b:= b xor l_key[4*(i+4)+1]; c:= c xor l_key[4*(i+4)+2]; d:= d xor l_key[4*(i+4)+3]; + t1:= not a; t2:= a xor d; t3:= a xor b; t4:= c xor t1; t5:= t2 or t3; e:= t4 xor t5; t7:= not e; t8:= b or t7; h:= t2 xor t8; t10:= a and e; t11:= b xor h; t12:= t8 and t11; g:= t10 xor t12; t14:= a or t7; t15:= t3 xor t14; t16:= h and g; f:= t15 xor t16; + e:= (e shl 13) or (e shr 19); g:= (g shl 3) or (g shr 29); f:= f xor e xor g; h:= h xor g xor (e shl 3); f:= (f shl 1) or (f shr 31); h:= (h shl 7) or (h shr 25); e:= e xor f xor h; g:= g xor h xor (f shl 7); e:= (e shl 5) or (e shr 27); g:= (g shl 22) or (g shr 10); + e:= e xor l_key[4*(i+5)]; f:= f xor l_key[4*(i+5)+1]; g:= g xor l_key[4*(i+5)+2]; h:= h xor l_key[4*(i+5)+3]; + t1:= not e; t2:= e xor f; t3:= e xor h; t4:= g xor t1; t5:= t2 or t3; a:= t4 xor t5; t7:= not h; t8:= a and t7; b:= t2 xor t8; t10:= f or b; t11:= g or a; t12:= t7 xor t10; d:= t11 xor t12; t14:= h or b; t15:= t1 xor t14; t16:= a or d; c:= t15 xor t16; + a:= (a shl 13) or (a shr 19); c:= (c shl 3) or (c shr 29); b:= b xor a xor c; d:= d xor c xor (a shl 3); b:= (b shl 1) or (b shr 31); d:= (d shl 7) or (d shr 25); a:= a xor b xor d; c:= c xor d xor (b shl 7); a:= (a shl 5) or (a shr 27); c:= (c shl 22) or (c shr 10); + a:= a xor l_key[4*(i+6)]; b:= b xor l_key[4*(i+6)+1]; c:= c xor l_key[4*(i+6)+2]; d:= d xor l_key[4*(i+6)+3]; + t1:= a xor c; t2:= b or d; t3:= b xor c; t4:= not t3; t5:= a and d; f:= t4 xor t5; t7:= b or c; t8:= d xor t1; t9:= t7 and t8; h:= t2 xor t9; t11:= t1 and t7; t12:= t4 xor t8; t13:= h and t11; e:= t12 xor t13; t15:= t3 xor t11; t16:= h or t15; g:= t12 xor t16; + e:= (e shl 13) or (e shr 19); g:= (g shl 3) or (g shr 29); f:= f xor e xor g; h:= h xor g xor (e shl 3); f:= (f shl 1) or (f shr 31); h:= (h shl 7) or (h shr 25); e:= e xor f xor h; g:= g xor h xor (f shl 7); e:= (e shl 5) or (e shr 27); g:= (g shl 22) or (g shr 10); + e:= e xor l_key[4*(i+7)]; f:= f xor l_key[4*(i+7)+1]; g:= g xor l_key[4*(i+7)+2]; h:= h xor l_key[4*(i+7)+3]; + t1:= not g; t2:= f xor g; t3:= f or t1; t4:= h xor t3; t5:= e and t4; d:= t2 xor t5; t7:= e xor h; t8:= f xor t5; t9:= t2 or t8; b:= t7 xor t9; t11:= h and t3; t12:= t5 xor b; t13:= d and t12; c:= t11 xor t13; t15:= t1 or t4; t16:= t12 xor c; a:= t15 xor t16; + + Inc(i,8); + if i < 32 then + begin + a:= (a shl 13) or (a shr 19); c:= (c shl 3) or (c shr 29); b:= b xor a xor c; d:= d xor c xor (a shl 3); b:= (b shl 1) or (b shr 31); d:= (d shl 7) or (d shr 25); a:= a xor b xor d; c:= c xor d xor (b shl 7); a:= (a shl 5) or (a shr 27); c:= (c shl 22) or (c shr 10); + end; + end; + a:= a xor l_key[128]; b:= b xor l_key[128+1]; c:= c xor l_key[128+2]; d:= d xor l_key[128+3]; + + PDWord(longword(@OutData)+ 0)^:= a; + PDWord(longword(@OutData)+ 4)^:= b; + PDWord(longword(@OutData)+ 8)^:= c; + PDWord(longword(@OutData)+12)^:= d; +end; + +procedure Tserpent.DecryptECB(const InData; var OutData); +var + i: integer; + a, b, c, d, e, f, g, h: dword; + t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14, t15, t16: dword; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + + a:= PDWord(@InData)^; + b:= PDWord(longword(@InData)+4)^; + c:= PDWord(longword(@InData)+8)^; + d:= PDWord(longword(@InData)+12)^; + + i:= 32; + a:= a xor l_key[4*32]; b:= b xor l_key[4*32+1]; c:= c xor l_key[4*32+2]; d:= d xor l_key[4*32+3]; + while i > 0 do + begin + if i < 32 then + begin + c:= (c shr 22) or (c shl 10); a:= (a shr 5) or (a shl 27); c:= c xor d xor (b shl 7); a:= a xor b xor d; d:= (d shr 7) or (d shl 25); b:= (b shr 1) or (b shl 31); d:= d xor c xor (a shl 3); b:= b xor a xor c; c:= (c shr 3) or (c shl 29); a:= (a shr 13) or (a shl 19); + end; + + t1:= a and b; t2:= a or b; t3:= c or t1; t4:= d and t2; h:= t3 xor t4; t6:= not d; t7:= b xor t4; t8:= h xor t6; t9:= t7 or t8; f:= a xor t9; t11:= c xor t7; t12:= d or f; e:= t11 xor t12; t14:= a and h; t15:= t3 xor f; t16:= e xor t14; g:= t15 xor t16; + e:= e xor l_key[4*(i-1)]; f:= f xor l_key[4*(i-1)+1]; g:= g xor l_key[4*(i-1)+2]; h:= h xor l_key[4*(i-1)+3]; + g:= (g shr 22) or (g shl 10); e:= (e shr 5) or (e shl 27); g:= g xor h xor (f shl 7); e:= e xor f xor h; h:= (h shr 7) or (h shl 25); f:= (f shr 1) or (f shl 31); h:= h xor g xor (e shl 3); f:= f xor e xor g; g:= (g shr 3) or (g shl 29); e:= (e shr 13) or (e shl 19); + t1:= not g; t2:= e xor g; t3:= f xor h; t4:= e or t1; b:= t3 xor t4; t6:= e or f; t7:= f and t2; t8:= b xor t6; t9:= t7 or t8; a:= g xor t9; t11:= not b; t12:= h or t2; t13:= t9 xor t11; d:= t12 xor t13; t15:= f xor t11; t16:= a and d; c:= t15 xor t16; + a:= a xor l_key[4*(i-2)]; b:= b xor l_key[4*(i-2)+1]; c:= c xor l_key[4*(i-2)+2]; d:= d xor l_key[4*(i-2)+3]; + c:= (c shr 22) or (c shl 10); a:= (a shr 5) or (a shl 27); c:= c xor d xor (b shl 7); a:= a xor b xor d; d:= (d shr 7) or (d shl 25); b:= (b shr 1) or (b shl 31); d:= d xor c xor (a shl 3); b:= b xor a xor c; c:= (c shr 3) or (c shl 29); a:= (a shr 13) or (a shl 19); + t1:= not c; t2:= b and t1; t3:= d xor t2; t4:= a and t3; t5:= b xor t1; h:= t4 xor t5; t7:= b or h; t8:= a and t7; f:= t3 xor t8; t10:= a or d; t11:= t1 xor t7; e:= t10 xor t11; t13:= a xor c; t14:= b and t10; t15:= t4 or t13; g:= t14 xor t15; + e:= e xor l_key[4*(i-3)]; f:= f xor l_key[4*(i-3)+1]; g:= g xor l_key[4*(i-3)+2]; h:= h xor l_key[4*(i-3)+3]; + g:= (g shr 22) or (g shl 10); e:= (e shr 5) or (e shl 27); g:= g xor h xor (f shl 7); e:= e xor f xor h; h:= (h shr 7) or (h shl 25); f:= (f shr 1) or (f shl 31); h:= h xor g xor (e shl 3); f:= f xor e xor g; g:= (g shr 3) or (g shl 29); e:= (e shr 13) or (e shl 19); + t1:= g xor h; t2:= g or h; t3:= f xor t2; t4:= e and t3; b:= t1 xor t4; t6:= e xor h; t7:= f or h; t8:= t6 and t7; d:= t3 xor t8; t10:= not e; t11:= g xor d; t12:= t10 or t11; a:= t3 xor t12; t14:= g or t4; t15:= t7 xor t14; t16:= d or t10; c:= t15 xor t16; + a:= a xor l_key[4*(i-4)]; b:= b xor l_key[4*(i-4)+1]; c:= c xor l_key[4*(i-4)+2]; d:= d xor l_key[4*(i-4)+3]; + c:= (c shr 22) or (c shl 10); a:= (a shr 5) or (a shl 27); c:= c xor d xor (b shl 7); a:= a xor b xor d; d:= (d shr 7) or (d shl 25); b:= (b shr 1) or (b shl 31); d:= d xor c xor (a shl 3); b:= b xor a xor c; c:= (c shr 3) or (c shl 29); a:= (a shr 13) or (a shl 19); + t1:= b xor c; t2:= b or c; t3:= a xor c; t4:= t2 xor t3; t5:= d or t4; e:= t1 xor t5; t7:= a xor d; t8:= t1 or t5; t9:= t2 xor t7; g:= t8 xor t9; t11:= a and t4; t12:= e or t9; f:= t11 xor t12; t14:= a and g; t15:= t2 xor t14; t16:= e and t15; h:= t4 xor t16; + e:= e xor l_key[4*(i-5)]; f:= f xor l_key[4*(i-5)+1]; g:= g xor l_key[4*(i-5)+2]; h:= h xor l_key[4*(i-5)+3]; + g:= (g shr 22) or (g shl 10); e:= (e shr 5) or (e shl 27); g:= g xor h xor (f shl 7); e:= e xor f xor h; h:= (h shr 7) or (h shl 25); f:= (f shr 1) or (f shl 31); h:= h xor g xor (e shl 3); f:= f xor e xor g; g:= (g shr 3) or (g shl 29); e:= (e shr 13) or (e shl 19); + t1:= f xor h; t2:= not t1; t3:= e xor g; t4:= g xor t1; t5:= f and t4; a:= t3 xor t5; t7:= e or t2; t8:= h xor t7; t9:= t3 or t8; d:= t1 xor t9; t11:= not t4; t12:= a or d; b:= t11 xor t12; t14:= h and t11; t15:= t3 xor t12; c:= t14 xor t15; + a:= a xor l_key[4*(i-6)]; b:= b xor l_key[4*(i-6)+1]; c:= c xor l_key[4*(i-6)+2]; d:= d xor l_key[4*(i-6)+3]; + c:= (c shr 22) or (c shl 10); a:= (a shr 5) or (a shl 27); c:= c xor d xor (b shl 7); a:= a xor b xor d; d:= (d shr 7) or (d shl 25); b:= (b shr 1) or (b shl 31); d:= d xor c xor (a shl 3); b:= b xor a xor c; c:= (c shr 3) or (c shl 29); a:= (a shr 13) or (a shl 19); + t1:= a xor d; t2:= a and b; t3:= b xor c; t4:= a xor t3; t5:= b or d; h:= t4 xor t5; t7:= c or t1; t8:= b xor t7; t9:= t4 and t8; f:= t1 xor t9; t11:= not t2; t12:= h and f; t13:= t9 xor t11; g:= t12 xor t13; t15:= a and d; t16:= c xor t13; e:= t15 xor t16; + e:= e xor l_key[4*(i-7)]; f:= f xor l_key[4*(i-7)+1]; g:= g xor l_key[4*(i-7)+2]; h:= h xor l_key[4*(i-7)+3]; + g:= (g shr 22) or (g shl 10); e:= (e shr 5) or (e shl 27); g:= g xor h xor (f shl 7); e:= e xor f xor h; h:= (h shr 7) or (h shl 25); f:= (f shr 1) or (f shl 31); h:= h xor g xor (e shl 3); f:= f xor e xor g; g:= (g shr 3) or (g shl 29); e:= (e shr 13) or (e shl 19); + t1:= e xor h; t2:= g xor h; t3:= not t2; t4:= e or f; c:= t3 xor t4; t6:= f xor t1; t7:= g or t6; t8:= e xor t7; t9:= t2 and t8; b:= t6 xor t9; t11:= not t8; t12:= f and h; t13:= b or t12; d:= t11 xor t13; t15:= t2 xor t12; t16:= b or d; a:= t15 xor t16; + a:= a xor l_key[4*(i-8)]; b:= b xor l_key[4*(i-8)+1]; c:= c xor l_key[4*(i-8)+2]; d:= d xor l_key[4*(i-8)+3]; + Dec(i,8); + end; + + PDWord(longword(@OutData)+ 0)^:= a; + PDWord(longword(@OutData)+ 4)^:= b; + PDWord(longword(@OutData)+ 8)^:= c; + PDWord(longword(@OutData)+12)^:= d; +end; + +var + MDS: array[0..3,0..255] of dword; + MDSDone: boolean; + + +function LFSR1(x: DWord): DWord; +begin + if (x and 1)<> 0 then + Result:= (x shr 1) xor (MDS_GF_FDBK div 2) + else + Result:= (x shr 1); +end; +function LFSR2(x: DWord): DWord; +begin + if (x and 2)<> 0 then + if (x and 1)<> 0 then + Result:= (x shr 2) xor (MDS_GF_FDBK div 2) xor (MDS_GF_FDBK div 4) + else + Result:= (x shr 2) xor (MDS_GF_FDBK div 2) + else + if (x and 1)<> 0 then + Result:= (x shr 2) xor (MDS_GF_FDBK div 4) + else + Result:= (x shr 2); +end; +function Mul_X(x: DWord): DWord; +begin + Result:= x xor LFSR2(x); +end; +function Mul_Y(x: DWord): DWord; +begin + Result:= x xor LFSR1(x) xor LFSR2(x); +end; + +function RS_MDS_Encode(lK0, lK1: DWord): DWord; +var + lR, nJ, lG2, lG3: DWord; + bB: byte; +begin + lR:= lK1; + for nJ:= 0 to 3 do + begin + bB:= lR shr 24; + if (bB and $80)<> 0 then + lG2:= ((bB shl 1) xor RS_GF_FDBK) and $FF + else + lG2:= (bB shl 1) and $FF; + if (bB and 1)<> 0 then + lG3:= ((bB shr 1) and $7f) xor (RS_GF_FDBK shr 1) xor lG2 + else + lG3:= ((bB shr 1) and $7f) xor lG2; + lR:= (lR shl 8) xor (lG3 shl 24) xor (lG2 shl 16) xor (lG3 shl 8) xor bB; + end; + lR:= lR xor lK0; + for nJ:= 0 to 3 do + begin + bB:= lR shr 24; + if (bB and $80)<> 0 then + lG2:= ((bB shl 1) xor RS_GF_FDBK) and $FF + else + lG2:= (bB shl 1) and $FF; + if (bB and 1)<> 0 then + lG3:= ((bB shr 1) and $7f) xor (RS_GF_FDBK shr 1) xor lG2 + else + lG3:= ((bB shr 1) and $7f) xor lG2; + lR:= (lR shl 8) xor (lG3 shl 24) xor (lG2 shl 16) xor (lG3 shl 8) xor bB; + end; + Result:= lR; +end; + +function f32(x: DWord; K32: PDWordArray; Len: DWord): DWord; +var + t0, t1, t2, t3: DWord; +begin + t0:= x and $FF; + t1:= (x shr 8) and $FF; + t2:= (x shr 16) and $FF; + t3:= x shr 24; + if Len= 256 then + begin + t0:= p8x8[1,t0] xor ((K32^[3]) and $FF); + t1:= p8x8[0,t1] xor ((K32^[3] shr 8) and $FF); + t2:= p8x8[0,t2] xor ((K32^[3] shr 16) and $FF); + t3:= p8x8[1,t3] xor ((K32^[3] shr 24)); + end; + if Len>= 192 then + begin + t0:= p8x8[1,t0] xor ((K32^[2]) and $FF); + t1:= p8x8[1,t1] xor ((K32^[2] shr 8) and $FF); + t2:= p8x8[0,t2] xor ((K32^[2] shr 16) and $FF); + t3:= p8x8[0,t3] xor ((K32^[2] shr 24)); + end; + Result:= MDS[0,p8x8[0,p8x8[0,t0] xor ((K32^[1]) and $FF)] xor ((K32^[0]) and $FF)] xor + MDS[1,p8x8[0,p8x8[1,t1] xor ((K32^[1] shr 8) and $FF)] xor ((K32^[0] shr 8) and $FF)] xor + MDS[2,p8x8[1,p8x8[0,t2] xor ((K32^[1] shr 16) and $FF)] xor ((K32^[0] shr 16) and $FF)] xor + MDS[3,p8x8[1,p8x8[1,t3] xor ((K32^[1] shr 24))] xor ((K32^[0] shr 24))]; +end; + +procedure Xor256(Dst, Src: PDWordArray; v: byte); +var + i, j: DWord; +begin + i:= 0; + j:= v * $01010101; + while i< 64 do + begin + Dst^[i]:= Src^[i] xor j; + Dst^[i+1]:= Src^[i+1] xor j; + Dst^[i+2]:= Src^[i+2] xor j; + Dst^[i+3]:= Src^[i+3] xor j; + Inc(i,4); + end; +end; + + +procedure PreCompMDS; +var + m1, mx, my: array[0..1] of DWord; + nI: longword; +begin + for nI:= 0 to 255 do + begin + m1[0]:= p8x8[0,nI]; + mx[0]:= Mul_X(m1[0]); + my[0]:= Mul_Y(m1[0]); + m1[1]:= p8x8[1,nI]; + mx[1]:= Mul_X(m1[1]); + my[1]:= Mul_Y(m1[1]); + mds[0,nI]:= (m1[1] shl 0) or + (mx[1] shl 8) or + (my[1] shl 16) or + (my[1] shl 24); + mds[1,nI]:= (my[0] shl 0) or + (my[0] shl 8) or + (mx[0] shl 16) or + (m1[0] shl 24); + mds[2,nI]:= (mx[1] shl 0) or + (my[1] shl 8) or + (m1[1] shl 16) or + (my[1] shl 24); + mds[3,nI]:= (mx[0] shl 0) or + (m1[0] shl 8) or + (my[0] shl 16) or + (mx[0] shl 24); + end; +end; +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} +destructor TTwofish.Destroy; +begin +// All Strings := ''; +// Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} +function NewTwofish; +begin +New(Result, Create); + if not MDSDone then + begin + PreCompMDS; + MDSDone:= true; + end; +// code +end; +//////////////////////////////////////////////////////////////////////////////// + + +procedure Ttwofish.InitKey(const Key; Size: longword); +const + subkeyCnt= ROUNDSUBKEYS + 2*NUMROUNDSTF; +var + key32: array[0..7] of DWord; + k32e, k32o, sboxkeys: array[0..3] of DWord; + k64Cnt, i, j, A, B, q: DWord; + L0, L1: array[0..255] of byte; +begin +burn; + FillChar(Key32,Sizeof(Key32),0); + Move(Key,Key32,Size div 8); + if Size<= 128 then { pad the key to either 128bit, 192bit or 256bit} + Size:= 128 + else if Size<= 192 then + Size:= 192 + else + Size:= 256; + k64Cnt:= Size div 64; + j:= k64Cnt-1; + for i:= 0 to j do + begin + k32e[i]:= key32[2*i]; + k32o[i]:= key32[2*i+1]; + sboxKeys[j]:= RS_MDS_Encode(k32e[i],k32o[i]); + Dec(j); + end; + q:= 0; + for i:= 0 to ((subkeyCnt div 2)-1) do + begin + A:= f32(q,@k32e,Size); + B:= f32(q+SK_BUMP,@k32o,Size); + B:= (B shl 8) or (B shr 24); + SubKeys[2*i]:= A+B; + B:= A + 2*B; + SubKeys[2*i+1]:= (B shl SK_ROTL) or (B shr (32 - SK_ROTL)); + Inc(q,SK_STEP); + end; + case Size of + 128: begin + Xor256(@L0,@p8x8[0],(sboxKeys[1] and $FF)); + A:= (sboxKeys[0] and $FF); + i:= 0; + while i< 256 do + begin + sBox[0 and 2,2*i+(0 and 1)]:= MDS[0,p8x8[0,L0[i]] xor A]; + sBox[0 and 2,2*i+(0 and 1)+2]:= MDS[0,p8x8[0,L0[i+1]] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[1],(sboxKeys[1] shr 8) and $FF); + A:= (sboxKeys[0] shr 8) and $FF; + i:= 0; + while i< 256 do + begin + sBox[1 and 2,2*i+(1 and 1)]:= MDS[1,p8x8[0,L0[i]] xor A]; + sBox[1 and 2,2*i+(1 and 1)+2]:= MDS[1,p8x8[0,L0[i+1]] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[0],(sboxKeys[1] shr 16) and $FF); + A:= (sboxKeys[0] shr 16) and $FF; + i:= 0; + while i< 256 do + begin + sBox[2 and 2,2*i+(2 and 1)]:= MDS[2,p8x8[1,L0[i]] xor A]; + sBox[2 and 2,2*i+(2 and 1)+2]:= MDS[2,p8x8[1,L0[i+1]] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[1],(sboxKeys[1] shr 24)); + A:= (sboxKeys[0] shr 24); + i:= 0; + while i< 256 do + begin + sBox[3 and 2,2*i+(3 and 1)]:= MDS[3,p8x8[1,L0[i]] xor A]; + sBox[3 and 2,2*i+(3 and 1)+2]:= MDS[3,p8x8[1,L0[i+1]] xor A]; + Inc(i,2); + end; + end; + 192: begin + Xor256(@L0,@p8x8[1],sboxKeys[2] and $FF); + A:= sboxKeys[0] and $FF; + B:= sboxKeys[1] and $FF; + i:= 0; + while i< 256 do + begin + sBox[0 and 2,2*i+(0 and 1)]:= MDS[0,p8x8[0,p8x8[0,L0[i]] xor B] xor A]; + sBox[0 and 2,2*i+(0 and 1)+2]:= MDS[0,p8x8[0,p8x8[0,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[1],(sboxKeys[2] shr 8) and $FF); + A:= (sboxKeys[0] shr 8) and $FF; + B:= (sboxKeys[1] shr 8) and $FF; + i:= 0; + while i< 256 do + begin + sBox[1 and 2,2*i+(1 and 1)]:= MDS[1,p8x8[0,p8x8[1,L0[i]] xor B] xor A]; + sBox[1 and 2,2*i+(1 and 1)+2]:= MDS[1,p8x8[0,p8x8[1,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[0],(sboxKeys[2] shr 16) and $FF); + A:= (sboxKeys[0] shr 16) and $FF; + B:= (sboxKeys[1] shr 16) and $FF; + i:= 0; + while i< 256 do + begin + sBox[2 and 2,2*i+(2 and 1)]:= MDS[2,p8x8[1,p8x8[0,L0[i]] xor B] xor A]; + sBox[2 and 2,2*i+(2 and 1)+2]:= MDS[2,p8x8[1,p8x8[0,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + Xor256(@L0,@p8x8[0],(sboxKeys[2] shr 24)); + A:= (sboxKeys[0] shr 24); + B:= (sboxKeys[1] shr 24); + i:= 0; + while i< 256 do + begin + sBox[3 and 2,2*i+(3 and 1)]:= MDS[3,p8x8[1,p8x8[1,L0[i]] xor B] xor A]; + sBox[3 and 2,2*i+(3 and 1)+2]:= MDS[3,p8x8[1,p8x8[1,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + end; + 256: begin + Xor256(@L1,@p8x8[1],(sboxKeys[3]) and $FF); + i:= 0; + while i< 256 do + begin + L0[i ]:= p8x8[1,L1[i]]; + L0[i+1]:= p8x8[1,L1[i+1]]; + Inc(i,2); + end; + Xor256(@L0,@L0,(sboxKeys[2]) and $FF); + A:= (sboxKeys[0]) and $FF; + B:= (sboxKeys[1]) and $FF; + i:= 0; + while i< 256 do + begin + sBox[0 and 2,2*i+(0 and 1)]:= MDS[0,p8x8[0,p8x8[0,L0[i]] xor B] xor A]; + sBox[0 and 2,2*i+(0 and 1)+2]:= MDS[0,p8x8[0,p8x8[0,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + Xor256(@L1,@p8x8[0],(sboxKeys[3] shr 8) and $FF); + i:= 0; + while i< 256 do + begin + L0[i ]:= p8x8[1,L1[i]]; + L0[i+1]:= p8x8[1,L1[i+1]]; + Inc(i,2); + end; + Xor256(@L0,@L0,(sboxKeys[2] shr 8) and $FF); + A:= (sboxKeys[0] shr 8) and $FF; + B:= (sboxKeys[1] shr 8) and $FF; + i:= 0; + while i< 256 do + begin + sBox[1 and 2,2*i+(1 and 1)]:= MDS[1,p8x8[0,p8x8[1,L0[i]] xor B] xor A]; + sBox[1 and 2,2*i+(1 and 1)+2]:= MDS[1,p8x8[0,p8x8[1,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + + Xor256(@L1,@p8x8[0],(sboxKeys[3] shr 16) and $FF); + i:= 0; + while i< 256 do + begin + L0[i ]:= p8x8[0,L1[i]]; + L0[i+1]:= p8x8[0,L1[i+1]]; + Inc(i,2); + end; + Xor256(@L0,@L0,(sboxKeys[2] shr 16) and $FF); + A:= (sboxKeys[0] shr 16) and $FF; + B:= (sboxKeys[1] shr 16) and $FF; + i:= 0; + while i< 256 do + begin + sBox[2 and 2,2*i+(2 and 1)]:= MDS[2,p8x8[1,p8x8[0,L0[i]] xor B] xor A]; + sBox[2 and 2,2*i+(2 and 1)+2]:= MDS[2,p8x8[1,p8x8[0,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + Xor256(@L1,@p8x8[1],(sboxKeys[3] shr 24)); + i:= 0; + while i< 256 do + begin + L0[i ]:= p8x8[0,L1[i]]; + L0[i+1]:= p8x8[0,L1[i+1]]; + Inc(i,2); + end; + Xor256(@L0,@L0,(sboxKeys[2] shr 24)); + A:= (sboxKeys[0] shr 24); + B:= (sboxKeys[1] shr 24); + i:= 0; + while i< 256 do + begin + sBox[3 and 2,2*i+(3 and 1)]:= MDS[3,p8x8[1,p8x8[1,L0[i]] xor B] xor A]; + sBox[3 and 2,2*i+(3 and 1)+2]:= MDS[3,p8x8[1,p8x8[1,L0[i+1]] xor B] xor A]; + Inc(i,2); + end; + end; + end; +end; + +procedure Ttwofish.Burn; +begin + FillChar(sBox,Sizeof(sBox),$FF); + FillChar(SubKeys,Sizeof(SubKeys),$FF); + inherited Burn; +end; + +procedure Ttwofish.EncryptECB(const InData; var OutData); +var + i: longword; + t0, t1: DWord; + X: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + x[0]:= PDWord(@InData)^ xor SubKeys[INPUTWHITEN]; + x[1]:= PDWord(longword(@InData)+4)^ xor SubKeys[INPUTWHITEN+1]; + x[2]:= PDWord(longword(@InData)+8)^ xor SubKeys[INPUTWHITEN+2]; + x[3]:= PDWord(longword(@InData)+12)^ xor SubKeys[INPUTWHITEN+3]; + i:= 0; + while i<= NUMROUNDSTF-2 do + begin + t0:= sBox[0,(x[0] shl 1) and $1fe] xor sBox[0,((x[0] shr 7) and $1fe)+1] + xor sBox[2,(x[0] shr 15) and $1fe] xor sBox[2,((x[0] shr 23) and $1fe)+1]; + t1:= sBox[0,((x[1] shr 23) and $1fe)] xor sBox[0,((x[1] shl 1) and $1fe)+1] + xor sBox[2,((x[1] shr 7) and $1fe)] xor sBox[2,((x[1] shr 15) and $1fe)+1]; + x[3]:= (x[3] shl 1) or (x[3] shr 31); + x[2]:= x[2] xor (t0 + t1 + SubKeys[ROUNDSUBKEYS+2*i]); + x[3]:= x[3] xor (t0 + 2*t1 + SubKeys[ROUNDSUBKEYS+2*i+1]); + x[2]:= (x[2] shr 1) or (x[2] shl 31); + + t0:= sBox[0,(x[2] shl 1) and $1fe] xor sBox[0,((x[2] shr 7) and $1fe)+1] + xor sBox[2,((x[2] shr 15) and $1fe)] xor sBox[2,((x[2] shr 23) and $1fe)+1]; + t1:= sBox[0,((x[3] shr 23) and $1fe)] xor sBox[0,((x[3] shl 1) and $1fe)+1] + xor sBox[2,((x[3] shr 7) and $1fe)] xor sBox[2,((x[3] shr 15) and $1fe)+1]; + x[1]:= (x[1] shl 1) or (x[1] shr 31); + x[0]:= x[0] xor (t0 + t1 + SubKeys[ROUNDSUBKEYS+2*(i+1)]); + x[1]:= x[1] xor (t0 + 2*t1 + SubKeys[ROUNDSUBKEYS+2*(i+1)+1]); + x[0]:= (x[0] shr 1) or (x[0] shl 31); + Inc(i,2); + end; + PDWord(longword(@OutData)+ 0)^:= x[2] xor SubKeys[OUTPUTWHITEN]; + PDWord(longword(@OutData)+ 4)^:= x[3] xor SubKeys[OUTPUTWHITEN+1]; + PDWord(longword(@OutData)+ 8)^:= x[0] xor SubKeys[OUTPUTWHITEN+2]; + PDWord(longword(@OutData)+12)^:= x[1] xor SubKeys[OUTPUTWHITEN+3]; +end; + +procedure Ttwofish.DecryptECB(const InData; var OutData); +var + i: integer; + t0, t1: DWord; + X: array[0..3] of DWord; +begin +// if not fInitialized then +// raise EDCP_blockcipher.Create('Cipher not initialized'); + X[2]:= PDWord(@InData)^ xor SubKeys[OUTPUTWHITEN]; + X[3]:= PDWord(longword(@InData)+4)^ xor SubKeys[OUTPUTWHITEN+1]; + X[0]:= PDWord(longword(@InData)+8)^ xor SubKeys[OUTPUTWHITEN+2]; + X[1]:= PDWord(longword(@InData)+12)^ xor SubKeys[OUTPUTWHITEN+3]; + i:= NUMROUNDSTF-2; + while i>= 0 do + begin + t0:= sBox[0,(x[2] shl 1) and $1fe] xor sBox[0,((x[2] shr 7) and $1fe)+1] + xor sBox[2,((x[2] shr 15) and $1fe)] xor sBox[2,((x[2] shr 23) and $1fe)+1]; + t1:= sBox[0,((x[3] shr 23) and $1fe)] xor sBox[0,((x[3] shl 1) and $1fe)+1] + xor sBox[2,((x[3] shr 7) and $1fe)] xor sBox[2,((x[3] shr 15) and $1fe)+1]; + x[0]:= (x[0] shl 1) or (x[0] shr 31); + x[0]:= x[0] xor (t0 + t1 + SubKeys[ROUNDSUBKEYS+2*(i+1)]); + x[1]:= x[1] xor (t0 + 2*t1 + SubKeys[ROUNDSUBKEYS+2*(i+1)+1]); + x[1]:= (x[1] shr 1) or (x[1] shl 31); + + t0:= sBox[0,(x[0] shl 1) and $1fe] xor sBox[0,((x[0] shr 7) and $1fe)+1] + xor sBox[2,(x[0] shr 15) and $1fe] xor sBox[2,((x[0] shr 23) and $1fe)+1]; + t1:= sBox[0,((x[1] shr 23) and $1fe)] xor sBox[0,((x[1] shl 1) and $1fe)+1] + xor sBox[2,((x[1] shr 7) and $1fe)] xor sBox[2,((x[1] shr 15) and $1fe)+1]; + x[2]:= (x[2] shl 1) or (x[2] shr 31); + x[2]:= x[2] xor (t0 + t1 + SubKeys[ROUNDSUBKEYS+2*i]); + x[3]:= x[3] xor (t0 + 2*t1 + SubKeys[ROUNDSUBKEYS+2*i+1]); + x[3]:= (x[3] shr 1) or (x[3] shl 31); + Dec(i,2); + end; + PDWord(longword(@OutData)+ 0)^:= X[0] xor SubKeys[INPUTWHITEN]; + PDWord(longword(@OutData)+ 4)^:= X[1] xor SubKeys[INPUTWHITEN+1]; + PDWord(longword(@OutData)+ 8)^:= X[2] xor SubKeys[INPUTWHITEN+2]; + PDWord(longword(@OutData)+12)^:= X[3] xor SubKeys[INPUTWHITEN+3]; +end; + + + + +initialization + ice_sboxdone:= false; + MDSdone:= false; + +end. diff --git a/Addons/KOLCCtrls.pas b/Addons/KOLCCtrls.pas new file mode 100644 index 0000000..0b429c8 --- /dev/null +++ b/Addons/KOLCCtrls.pas @@ -0,0 +1,1768 @@ +unit KOLCCtrls; + +interface + +uses + Windows, Messages, ShellAPI, KOL; + +{ ====== TRACKBAR CONTROL CONSTANTS =================== } + +const + TRACKBAR_CLASS = 'msctls_trackbar32'; + + TBS_AUTOTICKS = $0001; + TBS_VERT = $0002; + TBS_HORZ = $0000; + TBS_TOP = $0004; + TBS_BOTTOM = $0000; + TBS_LEFT = $0004; + TBS_RIGHT = $0000; + TBS_BOTH = $0008; + TBS_NOTICKS = $0010; + TBS_ENABLESELRANGE = $0020; + TBS_FIXEDLENGTH = $0040; + TBS_NOTHUMB = $0080; + TBS_TOOLTIPS = $0100; + + TBM_GETPOS = WM_USER; + TBM_GETRANGEMIN = WM_USER + 1; + TBM_GETRANGEMAX = WM_USER + 2; + TBM_GETTIC = WM_USER + 3; + TBM_SETTIC = WM_USER + 4; + TBM_SETPOS = WM_USER + 5; + TBM_SETRANGE = WM_USER + 6; + TBM_SETRANGEMIN = WM_USER + 7; + TBM_SETRANGEMAX = WM_USER + 8; + TBM_CLEARTICS = WM_USER + 9; + TBM_SETSEL = WM_USER + 10; + TBM_SETSELSTART = WM_USER + 11; + TBM_SETSELEND = WM_USER + 12; + TBM_GETPTICS = WM_USER + 14; + TBM_GETTICPOS = WM_USER + 15; + TBM_GETNUMTICS = WM_USER + 16; + TBM_GETSELSTART = WM_USER + 17; + TBM_GETSELEND = WM_USER + 18; + TBM_CLEARSEL = WM_USER + 19; + TBM_SETTICFREQ = WM_USER + 20; + TBM_SETPAGESIZE = WM_USER + 21; + TBM_GETPAGESIZE = WM_USER + 22; + TBM_SETLINESIZE = WM_USER + 23; + TBM_GETLINESIZE = WM_USER + 24; + TBM_GETTHUMBRECT = WM_USER + 25; + TBM_GETCHANNELRECT = WM_USER + 26; + TBM_SETTHUMBLENGTH = WM_USER + 27; + TBM_GETTHUMBLENGTH = WM_USER + 28; + TBM_SETTOOLTIPS = WM_USER + 29; + TBM_GETTOOLTIPS = WM_USER + 30; + TBM_SETTIPSIDE = WM_USER + 31; + + // TrackBar Tip Side flags + TBTS_TOP = 0; + TBTS_LEFT = 1; + TBTS_BOTTOM = 2; + TBTS_RIGHT = 3; + + TBM_SETBUDDY = WM_USER + 32; // wparam = BOOL fLeft; (or right) + TBM_GETBUDDY = WM_USER + 33; // wparam = BOOL fLeft; (or right) + TBM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; + TBM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; + + TB_LINEUP = 0; + TB_LINEDOWN = 1; + TB_PAGEUP = 2; + TB_PAGEDOWN = 3; + TB_THUMBPOSITION = 4; + TB_THUMBTRACK = 5; + TB_TOP = 6; + TB_BOTTOM = 7; + TB_ENDTRACK = 8; + + // custom draw item specs + TBCD_TICS = $0001; + TBCD_THUMB = $0002; + TBCD_CHANNEL = $0003; + + { ^^^^^^^^ TRACKBAR CONTROL ^^^^^^^^ } + +type + PTrackbar = ^TTrackbar; + TTrackbarOption = (trbAutoTicks, trbEnableSelRange, trbFixedLength, + trbNoThumb, trbNoTicks, trbTooltips, trbTopLeftMarks, + trbVertical, trbNoBorder); + TTrackbarOptions = set of TTrackbarOption; + + TOnScroll = procedure(Sender: PTrackbar; Code: Integer) of object; + {* Code: + |
+  TB_THUMBTRACK    Slider movement (the user dragged the slider)
+  TB_THUMBPOSITION WM_LBUTTONUP following a TB_THUMBTRACK notification message
+  TB_BOTTOM        VK_END
+  TB_ENDTRACK      WM_KEYUP (the user released a key that sent a relevant virtual key code)
+  TB_LINEDOWN      VK_RIGHT or VK_DOWN
+  TB_LINEUP        VK_LEFT or VK_UP
+  TB_PAGEDOWN      VK_NEXT (the user clicked the channel below or to the right of the slider)
+  TB_PAGEUP        VK_PRIOR (the user clicked the channel above or to the left of the slider)
+  TB_TOP           VK_HOME
+  |
+ } + + TTrackbar = object(TControl) + private + function GetOnScroll: TOnScroll; + procedure SetOnScroll(const Value: TOnScroll); + function GetVal(const Index: Integer): Integer; + procedure SetVal(const Index, Value: Integer); + procedure SetThumbLen(const Index, Value: Integer); + protected + public + property OnScroll: TOnScroll read GetOnScroll write SetOnScroll; + property RangeMin: Integer index $80010007 read GetVal write SetVal; + property RangeMax: Integer index $80020008 read GetVal write SetVal; + property PageSize: Integer index $00160015 read GetVal write SetVal; + property LineSize: Integer index $00180017 read GetVal write SetVal; + property Position: Integer index $80000005 read GetVal write SetVal; + property NumTicks: Integer index $00100000 read GetVal; + property SelStart: Integer index $0011000B read GetVal write SetVal; + property SelEnd: Integer index $0012000C read GetVal write SetVal; + property ThumbLen: Integer index $001B0000 read GetVal write SetThumbLen; + end; + + PTrackbarData = ^TTrackbarData; + TTrackbarData = packed record + FOnScroll: TOnScroll; + end; + + TKOLTrackbar = PTrackbar; + + { SPC CONTROLS } + + TSortBy = (sbName, sbExtention); + + PSPCDirectoryEdit = ^TSPCDirectoryEdit; + TSPCDirectoryEditBox = PSPCDirectoryEdit; + TSPCDirectoryEdit = object(TObj) + private + { Private declarations } + fCreated: Boolean; + fBorder: Integer; + fControl: PControl; + fEdit: PControl; + fButton: PControl; + fDirList: POpenDirDialog; + fFont: PGraphicTool; + fPath: string; + fTitle: string; + fCaptionEmpty: string; + fOnChange: TOnEvent; + fColor: TColor; + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + procedure DoClick(Sender: PObj); + procedure SetPath(Value: string); + procedure DoChange(Obj: PObj); + protected + { Protected declarations } + public + destructor Destroy; virtual; + procedure Initialize; + function SetAlign(Value: TControlAlign): PSPCDirectoryEdit; overload; + function SetPosition(X, Y: integer): PSPCDirectoryEdit; overload; + function SetSize(X, Y: integer): PSPCDirectoryEdit; overload; + function GetFont: PGraphicTool; + property Border: Integer read fBorder write fBorder; + { Public declarations } + property Font: PGraphicTool read GetFont; + property Color: TColor read fColor write fColor; + property Title: string read fTitle write fTitle; + property Path: string read fPath write SetPath; + property OnChange: TOnEvent read fOnChange write fOnChange; + property CaptionEmpty: string read fCaptionEmpty write fCaptionEmpty; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + end; + + TCase = (ctDefault, ctLower, ctUpper); + + PSPCFileList = ^TSPCFileList; + TSPCFileListBox = PSPCFileList; + TSPCFileList = object(TObj) + private + { Private declarations } + fColor: TColor; + fIcons: PImageList; + fFilters: string; + fIntegralHeight: Boolean; + fFileList: PDirList; + fControl: PControl; + fPath: string; + fFont: PGraphicTool; + FOnSelChange: TOnEvent; + fDoCase: TCase; + fHasBorder: Boolean; + fOnPaint: TOnPaint; + fExecuteOnDblClk: Boolean; + fSortBy: TSortBy; + FOnMouseDblClick: TOnMouse; + function GetVisible: Boolean; // Edited + procedure SetVisible(Value: Boolean); // Edited + function GetFocused: Boolean; + procedure SetFocused(Value: Boolean); + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + procedure DoSelChange(Sender: PObj); + procedure SetPath(Value: string); + procedure SetFilters(Value: string); + procedure SetIntegralHeight(Value: Boolean); + function GetCurIndex: Integer; + procedure SetCurIndex(Value: Integer); + procedure SetHasBorder(Value: Boolean); + function GetSelected(Index: Integer): Boolean; + procedure SetSelected(Index: Integer; Value: Boolean); + function GetItem(Index: Integer): string; + function DrawOneItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean; + procedure DoMouseDblClk(Sender: PControl; var Mouse: TMouseEventData); + procedure SetFont(Value: PGraphicTool); + procedure SetSortBy(Value: TSortBy); + protected + { Protected declarations } + public + property _SortBy: TSortBy read fSortBy write SetSortBy; + property OnMouseDblClk: TOnMouse read FOnMouseDblClick write FOnMouseDblClick; + destructor Destroy; virtual; + function GetFileName: string; + function GetFullFileName: string; + property Selected[Index: Integer]: Boolean read GetSelected write SetSelected; + property Items[Index: Integer]: string read GetItem; + function TotalSelected: Integer; + function SetPosition(X, Y: integer): PSPCFileList; overload; + function SetSize(X, Y: integer): PSPCFileList; overload; + function SetAlign(Value: TControlAlign): PSPCFileList; overload; + function GetFont: PGraphicTool; + { Public declarations } + property Color: TColor read fColor write fColor; + property Font: PGraphicTool read GetFont write SetFont; + property IntegralHeight: Boolean read fIntegralHeight write SetIntegralHeight; + property Path: string read fPath write SetPath; + property Filters: string read fFilters write SetFilters; + property OnSelChange: TOnEvent read FOnSelChange write FOnSelChange; + property OnPaint: TOnPaint read FOnPaint write FOnPaint; + property CurIndex: Integer read GetCurIndex write SetCurIndex; + function Count: LongInt; + property DoCase: TCase read fDoCase write fDoCase; + property HasBorder: Boolean read fHasBorder write SetHasBorder; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + property Visible: Boolean read GetVisible write SetVisible; // Edited + property Focused: Boolean read GetFocused write SetFocused; + property ExecuteOnDblClk: Boolean read fExecuteOnDblClk write fExecuteOnDblClk; + procedure SortByName; + procedure SortByExtention; + end; + + PSPCDirectoryList = ^TSPCDirectoryList; + TSPCDirectoryListBox = PSPCDirectoryList; + TSPCDirectoryList = object(TObj) + private + { Private declarations } + fColor: TColor; + fDoIndent: Boolean; + fTotalTree: Integer; + fDIcons: PImageList; + fFOLDER: PIcon; + fInitialized: Integer; + fCreated: Boolean; + fIntegralHeight: Boolean; + fDirList: PDirList; + fCurIndex: Integer; + fControl: PControl; + fPath: string; + fFont: PGraphicTool; + FOnMouseDblClick: TOnMouse; + fLVBkColor: Integer; + fOnChange: TOnEvent; + fFileListBox: PSPCFileList; + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + procedure DoMouseDblClick(Sender: PControl; var Mouse: TMouseEventData); + procedure SetPath(Value: string); + procedure SetFileListBox(Value: PSPCFileList); + protected + { Protected declarations } + public + destructor Destroy; virtual; + property FileListBox: PSPCFileList read fFileListBox write SetFileListBox; + function SetAlign(Value: TControlAlign): PSPCDirectoryList; overload; + function SetPosition(X, Y: integer): PSPCDirectoryList; overload; + function SetSize(X, Y: integer): PSPCDirectoryList; overload; + function GetFont: PGraphicTool; + property Color: TColor read fColor write fColor; + { Public declarations } + property Font: PGraphicTool read GetFont; + property IntegralHeight: Boolean read fIntegralHeight write fIntegralHeight; + property Path: string read fPath write SetPath; + property DoIndent: Boolean read fDoIndent write fDoIndent; + property OnMouseDblClk: TOnMouse read FOnMouseDblClick write FOnMouseDblClick; + property CurIndex: Integer read fCurIndex write fCurIndex; + property LVBkColor: Integer read fLVBkColor write fLVBkColor; + property OnChange: TOnEvent read fOnChange write fOnChange; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + end; + + PSPCDriveCombo = ^TSPCDriveCombo; + TSPCDriveComboBox = PSPCDriveCombo; + TSPCDriveCombo = object(TObj) + private + { Private declarations } + fIcons: PImageList; + fColor: TColor; + fInitialized: Integer; + fCurIndex: Integer; + fControl: PControl; + fDrive: char; + fFont: PGraphicTool; + fLVBkColor: Integer; + fOnChange: TOnEvent; + // fOnChangeInternal: TOnEvent; + fAOwner: PControl; + fDirectoryListBox: PSPCDirectoryList; + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + procedure SetDrive(Value: char); + procedure BuildList; + procedure DoChange(Obj: PObj); + // procedure DoChangeInternal(Obj: PObj); + function DoMeasureItem(Sender: PObj; Idx: Integer): Integer; + function DrawOneItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean; + protected + { Protected declarations } + public + destructor Destroy; virtual; + function SetAlign(Value: TControlAlign): PSPCDriveCombo; overload; + function SetPosition(X, Y: integer): PSPCDriveCombo; overload; + function SetSize(X, Y: integer): PSPCDriveCombo; overload; + function GetFont: PGraphicTool; + procedure SetFont(Value: PGraphicTool); + property Color: TColor read fColor write fColor; + { Public declarations } + property DirectoryListBox: PSPCDirectoryList read fDirectoryListBox write fDirectoryListBox; + property Font: PGraphicTool read GetFont write SetFont; + property Drive: char read fDrive write SetDrive; + property CurIndex: Integer read fCurIndex write fCurIndex; + property LVBkColor: Integer read fLVBkColor write fLVBkColor; + property OnChange: TOnEvent read fOnChange write fOnChange; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + end; + + TFilterItem = class + private + fFull: string; + fDescription: string; + fFilter: string; + public + published + property Full: string read fFull write fFull; + property Description: string read fDescription write fDescription; + property Filter: string read fFilter write fFilter; + end; + + PSPCFilterCombo = ^TSPCFilterCombo; + TSPCFilterComboBox = PSPCFilterCombo; + TSPCFilterCombo = object(TObj) + private + { Private declarations } + fColor: TColor; + fCurIndex: Integer; + fControl: PControl; + fFont: PGraphicTool; + fLVBkColor: Integer; + fOnChange: TOnEvent; + fFilterItems: PList; + fFilter: string; + fCreated: Boolean; + fInitialized: Integer; + fFileListBox: PSPCFileList; + ftext: string; + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + function GetFilterItem(Index: Integer): TFilterItem; + procedure SetFilter(Value: string); + procedure SetCurIndex(Value: Integer); + function GetCurIndex: Integer; + procedure DoChange(Obj: PObj); + function DoMeasureItem(Sender: PObj; Idx: Integer): Integer; + function GetItem(Index: Integer): string; + procedure SetItem(Index: Integer; Value: string); + function GetFilter: string; + protected + { Protected declarations } + public + destructor Destroy; virtual; + procedure Update; + procedure Add(fNewFilter: string); + procedure DeleteItem(Index: Integer); + function Count: Integer; + procedure BuildList; + property FileListBox: PSPCFileList read fFileListBox write fFileListBox; + function SetAlign(Value: TControlAlign): PSPCFilterCombo; overload; + function SetPosition(X, Y: integer): PSPCFilterCombo; overload; + function SetSize(X, Y: integer): PSPCFilterCombo; overload; + function GetFont: PGraphicTool; + procedure SetFont(Value: PGraphicTool); + property Filter: string read GetFilter write SetFilter; + property Color: TColor read fColor write fColor; + { Public declarations } + property Text: string read fText write fText; + property Font: PGraphicTool read GetFont write SetFont; + property CurIndex: Integer read GetCurIndex write SetCurIndex; + property LVBkColor: Integer read fLVBkColor write fLVBkColor; + property OnChange: TOnEvent read fOnChange write fOnChange; + property Items[Index: Integer]: string read GetItem write SetItem; + property Filters[Index: Integer]: TFilterItem read GetFilterItem; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + end; + + PSPCStatus = ^TSPCStatus; + TSPCStatusBar = PSPCStatus; + TSPCStatus = object(TControl) + private + { Private declarations } + fControl: PControl; + function GetTop: Integer; + procedure SetTop(Value: Integer); + function GetLeft: Integer; + procedure SetLeft(Value: Integer); + function GetHeight: Integer; + procedure SetHeight(Value: Integer); + function GetWidth: Integer; + procedure SetWidth(Value: Integer); + procedure SetSimpleStatusText(Value: string); + function GetSimpleStatusText: string; + protected + { Protected declarations } + public + destructor Destroy; virtual; + function SetAlign(Value: TControlAlign): PSPCStatus; overload; + function SetPosition(X, Y: integer): PSPCStatus; overload; + function SetSize(X, Y: integer): PSPCStatus; overload; + function GetFont: PGraphicTool; + procedure SetFont(Value: PGraphicTool); + { Public declarations } + property Font: PGraphicTool read GetFont write SetFont; + property SimpleStatusText: string read GetSimpleStatusText write SetSimpleStatusText; + property Height: Integer read GetHeight write SetHeight; + property Width: Integer read GetWidth write SetWidth; + property Top: Integer read GetTop write SetTop; + property Left: Integer read GetLeft write SetLeft; + // property SizeGrip; + end; + +function NewTrackbar(AParent: PControl; Options: TTrackbarOptions; OnScroll: TOnScroll): PTrackbar; + +function CheckBit(Value, Index: LongInt): Boolean; +function GetLastPos(c: char; s: string): Integer; +function NewTSPCDirectoryEditBox(AOwner: PControl): PSPCDirectoryEdit; +function NewTSPCDirectoryListBox(AOwner: PControl; Style: TListViewStyle; Options: TListViewOptions; ImageListSmall, ImageListNormal, ImageListState: PImageList): PSPCDirectoryList; +function NewTSPCDriveComboBox(AOwner: PControl; Options: TComboOptions): PSPCDriveCombo; +function NewTSPCFileListBox(AOwner: PControl; Options: TListOptions): PSPCFileList; +function NewTSPCFilterComboBox(AOwner: PControl; Options: TComboOptions): PSPCFilterCombo; +function NewTSPCStatusBar(AOwner: PControl): PSPCStatus; + +implementation + +function WndProcTrackbarParent(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var + D : PTrackbarData; + Trackbar : PTrackbar; +begin + Result := False; + if (Msg.message = WM_HSCROLL) or (Msg.message = WM_VSCROLL) then + if (Msg.lParam <> 0) then begin + Trackbar := Pointer({$IFDEF USE_PROP} + GetProp(Msg.lParam, ID_SELF) +{$ELSE} + GetWindowLong(Msg.lParam, GWL_USERDATA) +{$ENDIF}); + if Assigned(Trackbar) then begin + D := Trackbar.CustomData; + if Assigned(D.FOnScroll) then + D.FOnScroll(Trackbar, Msg.wParam); + end; + end; +end; + +function NewTrackbar(AParent: PControl; Options: TTrackbarOptions; OnScroll: TOnScroll): PTrackbar; +const + TrackbarOptions : array[TTrackbarOption] of Integer = (TBS_AUTOTICKS, + TBS_ENABLESELRANGE, TBS_FIXEDLENGTH, TBS_NOTHUMB, TBS_NOTICKS, TBS_TOOLTIPS, + TBS_TOP, TBS_VERT, 0); +var + aStyle : DWORD; + D : PTrackbarData; + W, H : Integer; +begin + DoInitCommonControls(ICC_BAR_CLASSES); + aStyle := MakeFlags(@Options, TrackbarOptions) or WS_CHILD or WS_VISIBLE; + Result := PTrackbar(_NewCommonControl(AParent, TRACKBAR_CLASS, aStyle, + not (trbNoBorder in Options), nil)); + W := 200; + H := 40; + if (trbVertical in Options) then begin + H := W; + W := 40; + end; + Result.Width := W; + Result.Height := H; + GetMem(D, Sizeof(D^)); + Result.CustomData := D; + D.FOnScroll := OnScroll; + AParent.AttachProc(WndProcTrackbarParent); +end; + +{ TTrackbar } + +function TTrackbar.GetOnScroll: TOnScroll; +var + D : PTrackbarData; +begin + D := CustomData; + Result := D.FOnScroll; +end; + +function TTrackbar.GetVal(const Index: Integer): Integer; +begin + Result := Perform(WM_USER + (HiWord(Index) and $7FFF), 0, 0); +end; + +procedure TTrackbar.SetOnScroll(const Value: TOnScroll); +var + D : PTrackbarData; +begin + D := CustomData; + D.FOnScroll := Value; +end; + +procedure TTrackbar.SetThumbLen(const Index, Value: Integer); +begin + Perform(TBM_SETTHUMBLENGTH, Value, 0); +end; + +procedure TTrackbar.SetVal(const Index, Value: Integer); +begin + Perform(WM_USER + LoWord(Index), Index shr 31, Value); +end; + +{ TSPCDirectoryEdit } + +function NewTSPCDirectoryEditBox; +var + p : PSPCDirectoryEdit; + c : PControl; +begin + c := NewPanel(AOwner, esNone); + c.ExStyle := c.ExStyle or WS_EX_CLIENTEDGE; + New(p, create); + AOwner.Add2AutoFree(p); + p.fControl := c; + p.fFont := NewFont; + p.fCreated := False; + Result := p; +end; + +function TSPCDirectoryEdit.SetAlign(Value: TControlAlign): PSPCDirectoryEdit; +begin + fControl.Align := Value; + Result := @Self; +end; + +destructor TSPCDirectoryEdit.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCDirectoryEdit.SetPosition(X, Y: integer): PSPCDirectoryEdit; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCDirectoryEdit.SetSize(X, Y: integer): PSPCDirectoryEdit; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCDirectoryEdit.GetFont; +begin + Result := fFont; +end; + +procedure TSPCDirectoryEdit.Initialize; +begin + fEdit := NewEditBox(fControl, [eoReadOnly]); + fEdit.Font.FontHeight := -11; + fControl.Height := fEdit.Height - 1; + fEdit.Left := 0; + fEdit.Top := 1; + fEdit.Height := 17; + fEdit.Width := fControl.Width - 21; + fEdit.HasBorder := False; + fEdit.Color := fColor; + fEdit.Font.Assign(Font); + fButton := NewBitBtn(fControl, '...', [], glyphLeft, 0, 1); + fButton.Font.FontHeight := -11; + fButton.VerticalAlign := vaCenter; + fButton.LikeSpeedButton; + fButton.Width := 17; + fButton.Height := 17; + fButton.Top := 0; + fButton.Left := fEdit.Width; + fButton.OnClick := DoClick; + fDirList := NewOpenDirDialog(Title, []); + fDirList.CenterOnScreen := True; +end; + +procedure TSPCDirectoryEdit.SetPath(Value: string); +begin + if DirectoryExists(Value) then fPath := Value else fPath := ''; + if Length(fPath) = 0 then fEdit.Text := CaptionEmpty else fEdit.Text := fPath; + if Assigned(fOnChange) then if fCreated then fOnChange(@Self) else fCreated := True; +end; + +procedure TSPCDirectoryEdit.DoClick; +begin + fDirList.InitialPath := Path; + if fDirList.Execute then begin + Path := fDirList.Path; + fEdit.Text := fDirList.Path; + end; +end; + +procedure TSPCDirectoryEdit.DoChange; +begin + if Assigned(fOnChange) then fOnChange(@Self); +end; + +function TSPCDirectoryEdit.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCDirectoryEdit.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCDirectoryEdit.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCDirectoryEdit.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCDirectoryEdit.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCDirectoryEdit.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCDirectoryEdit.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCDirectoryEdit.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +{ TSPCDirectoryList } + +function NewTSPCDirectoryListBox; +var + p : PSPCDirectoryList; + c : PControl; + Shell32 : LongInt; +begin + c := NewListView(AOwner, lvsDetailNoHeader, [], ImageListSmall, ImageListNormal, ImageListState); + New(p, create); + AOwner.Add2AutoFree(p); + p.fControl := c; + p.fControl.OnMouseDblClk := p.DoMouseDblClick; + p.fControl.lvOptions := [lvoRowSelect, lvoInfoTip, lvoAutoArrange]; + p.fCreated := False; + p.fDirList := NewDirList('', '', 0); + p.fFont := NewFont; + p.fDIcons := NewImageList(AOwner); + p.fDIcons.LoadSystemIcons(True); + Shell32 := LoadLibrary('shell32.dll'); + p.fFOLDER := NewIcon; + p.fFOLDER.LoadFromResourceID(Shell32, 4, 16); + p.fDIcons.ReplaceIcon(0, p.fFOLDER.Handle); + p.fFOLDER.LoadFromResourceID(Shell32, 5, 16); + p.fDIcons.ReplaceIcon(1, p.fFOLDER.Handle); + FreeLibrary(Shell32); + p.fFOLDER.Free; + p.fControl.ImageListSmall := p.fDIcons; + p.fInitialized := 0; + Result := p; +end; + +function TSPCDirectoryList.SetAlign(Value: TControlAlign): PSPCDirectoryList; +begin + fControl.Align := Value; + Result := @Self; +end; + +procedure TSPCDirectoryList.DoMouseDblClick; +var + s : string; + i : Integer; +begin + if fControl.lvCurItem > -1 then begin + s := ''; + if fControl.LVCurItem <= fTotalTree - 1 then begin + for i := 0 to fControl.LVCurItem do s := s + fControl.lvItems[i, 0] + '\'; + end else begin + for i := 0 to fTotalTree - 1 do s := s + fControl.lvItems[i, 0] + '\'; + s := s + fControl.lvItems[fControl.lvCurItem, 0]; + end; + Path := s; + if Assigned(fOnMouseDblClick) then fOnMouseDblClick(@Self, Mouse); + end; +end; + +destructor TSPCDirectoryList.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCDirectoryList.SetPosition(X, Y: integer): PSPCDirectoryList; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCDirectoryList.SetSize(X, Y: integer): PSPCDirectoryList; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCDirectoryList.GetFont; +begin + Result := fFont; +end; + +procedure TSPCDirectoryList.SetPath(Value: string); +var + TPath, fValue : string; + i, z : Integer; + LastDir : Cardinal; + fImgIndex : Integer; + Code : Cardinal; + fDriveShown : Boolean; +begin + fValue := Value; + fControl.lvBkColor := fColor; + fControl.lvTextBkColor := fColor; + if Length(fValue) = 1 then fValue := fValue + ':\'; + if not fCreated then begin + fCreated := True; + fControl.LVColAdd('', taRight, fControl.Width); + // if fIntegralHeight then + // begin + // fControl.Height:=(fControl.Height div 16)*16+1; + // end; + end; + fControl.Clear; + if DirectoryExists(fValue) then begin + LastDir := 0; + fTotalTree := 0; + if fValue[Length(fValue)] = '\' then TPath := fValue else TPath := fValue + '\'; + fPath := TPath; + fDriveShown := False; + repeat + if fTotalTree > 0 then fImgIndex := 1; + if not fDriveShown then begin + fDriveShown := True; + fImgIndex := FileIconSystemIdx(Copy(TPath, 1, 3)); + end; + fControl.LVAdd(Copy(TPath, 1, Pos('\', TPath) - 1), fImgIndex, [], 0, 0, 0); + fControl.LVItemIndent[LastDir] := LastDir; + Delete(TPath, 1, Pos('\', TPath)); + if DoIndent then Inc(LastDir); + Inc(fTotalTree); + until Length(TPath) = 0; + fDirList.ScanDirectory(fValue, '*.*', FILE_ATTRIBUTE_NORMAL); + fDirList.Sort([sdrByName]); + z := -1; + for i := 0 to fDirList.Count - 1 do begin + Code := fDirList.Items[i].dwFileAttributes; + if Code = (Code or $10) then + if not (fDirList.Names[i] = '.') then + if not (fDirList.Names[i] = '..') then begin + Inc(z); + fControl.LVAdd(fDirList.Names[i], 0, [], 0, 0, 0); + if DoIndent then fControl.LVItemIndent[z + fTotalTree] := LastDir else fControl.LVItemIndent[z + fTotalTree] := 1; + end; + end; + end else begin + fPath := ''; + end; + Inc(fInitialized); + if fInitialized > 2 then fInitialized := 2; + if Assigned(OnChange) then if fInitialized = 2 then OnChange(@Self); + if Assigned(fFileListBox) then fFileListBox.Path := Path; + fControl.LVColWidth[0] := -2; +end; + +function TSPCDirectoryList.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCDirectoryList.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCDirectoryList.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCDirectoryList.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCDirectoryList.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCDirectoryList.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCDirectoryList.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCDirectoryList.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +procedure TSPCDirectoryList.SetFileListBox(Value: PSPCFileList); +begin + fFileListBox := Value; + fFileListBox.Path := Path; +end; + +{ TSPCDriveCombo } + +function CheckBit; +var + fL : LongInt; +begin + fL := Value; + fL := fL shr Index; + fL := fL and $01; + Result := (fL = 1); +end; + +function NewTSPCDriveComboBox; +var + p : PSPCDriveCombo; + c : PControl; +begin + c := NewComboBox(AOwner, [coReadOnly, coOwnerDrawVariable]); + New(p, create); + AOwner.Add2AutoFree(p); + p.fControl := c; + p.fFont := NewFont; + p.fFont.FontHeight := -8; + p.fControl.Font.Assign(p.fFont); + p.fIcons := NewImageList(AOwner); + p.fIcons.LoadSystemIcons(True); + p.fAOwner := AOwner; + p.fControl.OnDrawItem := p.DrawOneItem; + p.fControl.OnChange := p.DoChange; + p.fControl.OnMeasureItem := p.DoMeasureItem; + p.BuildList; + p.fInitialized := 0; + p.fControl.Color := $FF0000; + Result := p; +end; + +procedure TSPCDriveCombo.DoChange(Obj: PObj); +begin + Drive := fControl.Items[fControl.CurIndex][1]; + SetCurrentDirectory(PChar(Drive + ':\')); + if Assigned(fOnChange) then fOnChange(@Self); + if Assigned(fDirectoryListBox) then fDirectoryListBox.Path := Drive; +end; + +destructor TSPCDriveCombo.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCDriveCombo.SetAlign(Value: TControlAlign): PSPCDriveCombo; +begin + fControl.Align := Value; + Result := @Self; +end; + +function TSPCDriveCombo.SetPosition(X, Y: integer): PSPCDriveCombo; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCDriveCombo.SetSize(X, Y: integer): PSPCDriveCombo; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCDriveCombo.GetFont; +begin + Result := fFont; +end; + +procedure TSPCDriveCombo.SetFont(Value: PGraphicTool); +begin + fFont := Value; + fControl.Font.Assign(Value); +end; + +procedure TSPCDriveCombo.SetDrive; +var + fC : Char; +begin + fControl.Font.Assign(fFont); + fControl.Color := fColor; + fC := Value; + if fControl.SearchFor(fc, 0, True) > -1 then begin + fDrive := fC; + fControl.CurIndex := fControl.SearchFor(fc, 0, True); + end; + Inc(fInitialized); + if fInitialized > 2 then fInitialized := 2; + if Assigned(fOnChange) then if fInitialized = 2 then fOnChange(@Self); +end; + +function VolumeID(DriveChar: Char): string; +var + NotUsed, VolFlags : DWORD; + Buf : array[0..MAX_PATH] of Char; +begin + if GetVolumeInformation(PChar(DriveChar + ':\'), Buf, DWORD(sizeof(Buf)), nil, NotUsed, VolFlags, nil, 0) then Result := Copy(Buf, 1, StrLen(Buf)) else + Result := ''; +end; + +function dr_property(path: string): string; +var + Cpath : Pchar; + Spath : Char; +begin + Result := ''; + Cpath := PChar(Copy(path, 1, 2)); + Spath := Cpath[0]; + case GetDriveType(Cpath) of + 0: Result := ''; //Не известен + 1: Result := ''; //Не существует :) + DRIVE_REMOVABLE: Result := 'Removable'; //Флопик + DRIVE_FIXED: if Length(VolumeID(Spath)) > 0 then Result := VolumeID(Spath) else Result := 'Local Disk'; //HDD + DRIVE_REMOTE: if Length(VolumeID(Spath)) > 0 then Result := VolumeID(Spath) else Result := 'Net Disk'; //Внешний носитель + // DRIVE_REMOTE: if Length(VolumeID(Spath))>0 then Result:=NetworkVolume(Spath) else Result:='Net Disk';//Внешний носитель + DRIVE_CDROM: if Length(VolumeID(Spath)) > 0 then Result := VolumeID(Spath) else Result := 'Compact Disc'; //CD + DRIVE_RAMDISK: if Length(VolumeID(Spath)) > 0 then Result := VolumeID(Spath) else Result := 'Removable Disk'; //Внешний носитель + end; +end; + +procedure TSPCDriveCombo.BuildList; +var + b : Byte; + fFlags : LongInt; + fDir : string; + // a : integer; + fFullPath : string; + fdr_property : string; +begin + GetDir(0, fDir); + fControl.Clear; + fFlags := GetLogicalDrives; + for b := 0 to 25 do if Boolean(fFlags and (1 shl b)) then begin + fFullPath := Chr(b + $41) + ':'; + fdr_property := dr_property(fFullPath); + {a :=}fControl.Add(Chr(b + $41) + ' ' + fdr_property); + end; + fControl.CurIndex := fControl.SearchFor(fDir[1], 0, True); + fControl.Update; +end; + +function TSPCDriveCombo.DrawOneItem(Sender: PObj; DC: HDC; //aded by tamerlan311 + const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; + ItemState: TDrawState): Boolean; +var + T_Rect : TRect; + B_Rect : TRect; + Ico : Integer; +begin + SetBkMode(DC, opaque); + if ItemIdx > -1 then begin + //PControl(Sender).CanResize := True; + T_Rect := Rect; + B_Rect := Rect; + T_Rect.Left := Rect.Left + 19; + B_Rect.Left := Rect.Left + 18; + PControl(Sender).Canvas.Pen.PenMode := pmCopy; + PControl(Sender).Canvas.Pen.Color := $0000FF; + PControl(Sender).Brush.Color := clWindow; + if (odsFocused in ItemState) or (odsSelected in ItemState) then begin + SetBkMode(DC, TRANSPARENT); + PControl(Sender).Canvas.Brush.color := clWindow; + FillRect(DC, T_Rect, PControl(Sender).Canvas.Brush.Handle); + if (not (odsFocused in ItemState)) and ((odsSelected in ItemState)) then begin + PControl(Sender).Canvas.Brush.color := clInactiveBorder; + SetTextColor(DC, Font.Color); + fIcons.DrawingStyle := []; + end else begin + PControl(Sender).Canvas.Brush.color := clHighLight; + SetTextColor(DC, $FFFFFF); + fIcons.DrawingStyle := [dsBlend50]; + end; + FillRect(DC, T_Rect, PControl(Sender).Canvas.Brush.Handle); + end else begin + SetTextColor(DC, Font.Color); + PControl(Sender).Canvas.Brush.color := clWindow; + SelectObject(DC, PControl(Sender).Canvas.Brush.Handle); + FillRect(DC, B_Rect, PControl(Sender).Canvas.Brush.Handle); + fIcons.DrawingStyle := []; + end; + Ico := FileIconSystemIdx(PControl(Sender).Items[ItemIdx][1] + ':\'); + fIcons.Draw(Ico, DC, Rect.Left + 1, Rect.Top); + DrawText(DC, PChar(PControl(Sender).Items[ItemIdx]), Length(PControl(Sender).Items[ItemIdx]), T_Rect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); + end; + // PControl(Sender).Update; + Result := True; /// +end; + +function TSPCDriveCombo.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCDriveCombo.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCDriveCombo.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCDriveCombo.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCDriveCombo.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCDriveCombo.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCDriveCombo.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCDriveCombo.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +function TSPCDriveCombo.DoMeasureItem(Sender: PObj; Idx: Integer): Integer; +begin + Result := 16; +end; + +{ TSPCFileList } + +function NewTSPCFileListBox; +var + p : PSPCFileList; +begin + Options := Options + [loOwnerDrawFixed]; + New(p, Create); + AOwner.Add2AutoFree(p); + p.fControl := NewListBox(AOwner, Options); + // p.fControl.OnMouseDblClk:=p.DoMouseDblClick; + p.fControl.OnChange := p.DoSelChange; + p.fControl.Font.FontHeight := -8; + p.fFileList := NewDirList('', '', 0); + p.fControl.OnDrawItem := p.DrawOneItem; + p.fFont := NewFont; + p.fIcons := NewImageList(nil); + p.fIcons.LoadSystemIcons(true); + p.fControl.OnMouseDblClk := p.DoMouseDblClk; + p.fControl.Font.FontHeight := -11; + Result := p; +end; + +function TSPCFileList.SetAlign(Value: TControlAlign): PSPCFileList; +begin + fControl.Align := Value; + Result := @Self; +end; + +procedure TSPCFileList.SetFilters(Value: string); +begin + fFilters := Value; + Path := Path; +end; + +procedure TSPCFileList.DoSelChange; +begin + if Assigned(fOnSelChange) then fOnSelChange(@Self); +end; + +destructor TSPCFileList.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCFileList.SetPosition(X, Y: integer): PSPCFileList; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCFileList.SetSize(X, Y: integer): PSPCFileList; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCFileList.GetFont; +begin + Result := fControl.Font; +end; + +procedure TSPCFileList.SetFont(Value: PGraphicTool); +begin + fControl.Font.Assign(Value); +end; + +procedure TSPCFileList.SetPath(Value: string); +var + i : Integer; + fValue : string; +begin + fValue := Value; + if Length(fValue) > 0 then begin + if not (fValue[Length(fValue)] = '\') then fValue := fValue + '\'; + end; + if DirectoryExists(fValue) then begin + fFileList.Clear; + fFileList.ScanDirectoryEx(FileShortPath(fValue), Filters, FILE_ATTRIBUTE_NORMAL and not FILE_ATTRIBUTE_DIRECTORY); + fControl.Clear; + fControl.Color := fColor; + case _SortBy of + sbName: fFileList.Sort([sdrByName]); + sbExtention: fFileList.Sort([sdrByExt]); + end; + for i := 1 to fFileList.Count do if not fFileList.IsDirectory[i - 1] then fControl.Add(fFileList.Names[i - 1]); + fPath := fValue; + if fDoCase = ctLower then for i := 0 to fControl.Count - 1 do fControl.Items[i] := LowerCase(fControl.Items[i]); + if fDoCase = ctUpper then for i := 0 to fControl.Count - 1 do fControl.Items[i] := UpperCase(fControl.Items[i]); + end else begin + fControl.Clear; + fPath := ''; + end; + if fIntegralHeight then begin + fControl.Height := Round(fControl.Height / 16) * 16 + 4; + end; +end; + +procedure TSPCFileList.SetIntegralHeight; +begin + fIntegralHeight := Value; + if fIntegralHeight then begin + fControl.Height := (fControl.Height div 14) * 14 + 6; + end; +end; + +function TSPCFileList.GetFileName: string; +begin + Result := fControl.Items[fControl.CurIndex]; +end; + +function TSPCFileList.GetFullFileName: string; +begin + Result := Path + fControl.Items[fControl.CurIndex] +end; + +function TSPCFileList.Count: LongInt; +begin + Result := fControl.Count; +end; + +function TSPCFileList.GetCurIndex: Integer; +begin + Result := fControl.CurIndex; +end; + +procedure TSPCFileList.SetCurIndex(Value: Integer); +begin + fControl.CurIndex := Value; +end; + +procedure TSPCFileList.SetHasBorder(Value: Boolean); +var + NewStyle : DWORD; +begin + if Value then + fControl.Style := fControl.Style or WS_THICKFRAME + else begin + NewStyle := fControl.Style and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION + or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU or WS_HSCROLL); + if not fControl.IsControl then NewStyle := NewStyle or WS_POPUP; + fControl.Style := NewStyle; + fControl.ExStyle := fControl.ExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME + or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); + end; +end; + +function TSPCFileList.GetSelected(Index: Integer): Boolean; +begin + if Index > Count - 1 then Result := False else Result := fControl.ItemSelected[Index]; +end; + +procedure TSPCFileList.SetSelected(Index: Integer; Value: Boolean); +begin + if Index <= Count - 1 then fControl.ItemSelected[Index] := Value; +end; + +function TSPCFileList.TotalSelected: Integer; +var + i : Integer; +begin + Result := 0; + if fControl.Count = 0 then Result := -1 else begin + for i := 0 to fControl.Count - 1 do if fControl.ItemSelected[i] then Result := Result + 1; + end; +end; + +function TSPCFileList.GetItem(Index: Integer): string; +begin + Result := fControl.Items[Index]; +end; + +function TSPCFileList.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCFileList.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCFileList.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCFileList.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCFileList.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCFileList.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCFileList.GetVisible: Boolean; // Edited +begin + Result := FControl.Visible; +end; + +procedure TSPCFileList.SetVisible(Value: Boolean); // Edited +begin + FControl.Visible := Value; +end; + +function TSPCFileList.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCFileList.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +function TSPCFileList.GetFocused: Boolean; +begin + Result := fControl.Focused; +end; + +procedure TSPCFileList.SetFocused(Value: Boolean); +begin + fControl.Focused := Value; +end; + +function TSPCFileList.DrawOneItem(Sender: PObj; DC: HDC; + const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; + ItemState: TDrawState): Boolean; +var + T_Rect, B_Rect : TRect; + Ico : Integer; +begin + SetBkMode(DC, opaque); + if ItemIdx > -1 then begin + PControl(Sender).CanResize := True; + T_Rect := Rect; + B_Rect := Rect; + T_Rect.Left := Rect.Left + 19; + B_Rect.Left := Rect.Left + 18; + PControl(Sender).Canvas.Pen.PenMode := pmCopy; + PControl(Sender).Canvas.Pen.Color := $0000FF; + PControl(Sender).Brush.Color := clWindow; + if (odsFocused in ItemState) or (odsSelected in ItemState) then begin + SetBkMode(DC, transparent); + PControl(Sender).Canvas.Brush.color := clWindow; + FillRect(DC, T_Rect, PControl(Sender).Canvas.Brush.Handle); + if (not (odsFocused in ItemState)) and ((odsSelected in ItemState)) then begin + PControl(Sender).Canvas.Brush.color := clInactiveBorder; + SetTextColor(DC, Font.Color); + fIcons.DrawingStyle := []; + end + else begin + PControl(Sender).Canvas.Brush.color := clHighLight; + SetTextColor(DC, $FFFFFF); + fIcons.DrawingStyle := [dsBlend50]; + end; + FillRect(DC, T_Rect, PControl(Sender).Canvas.Brush.Handle); + end else begin + SetTextColor(DC, Font.Color); + PControl(Sender).Canvas.Brush.color := clWindow; + SelectObject(DC, PControl(Sender).Canvas.Brush.Handle); + FillRect(DC, B_Rect, PControl(Sender).Canvas.Brush.Handle); + fIcons.DrawingStyle := []; + end; + Ico := FileIconSystemIdx(Path + PControl(Sender).Items[ItemIdx]); + fIcons.Draw(Ico, DC, Rect.Left + 1, Rect.Top); + DrawText(DC, PChar(PControl(Sender).Items[ItemIdx]), Length(PControl(Sender).Items[ItemIdx]), T_Rect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); + end; + PControl(Sender).Update; + Result := True; /// +end; + +procedure TSPCFileList.DoMouseDblClk(Sender: PControl; var Mouse: TMouseEventData); +begin + if ExecuteOnDblClk then ShellExecuteA(fControl.Handle, nil, PChar(Path + Sender.Items[CurIndex]), '', '', SW_SHOW) else + if Assigned(fOnMouseDblClick) then fOnMouseDblClick(@Self, Mouse); +end; + +procedure TSPCFileList.SetSortBy(Value: TSortBy); +begin + fSortBy := Value; + Path := Path; +end; + +procedure TSPCFileList.SortByName; +begin + _SortBy := sbName; +end; + +procedure TSPCFileList.SortByExtention; +begin + _SortBy := sbExtention; +end; + +{ TSPCFilterCombo } + +function GetLastPos(c: char; s: string): Integer; +var + i : Integer; +begin + Result := 0; + for i := 1 to Length(s) do if s[i] = c then Result := i; +end; + +function NewTSPCFilterComboBox; +var + p : PSPCFilterCombo; + c : PControl; +begin + c := NewComboBox(AOwner, [coReadOnly]); + New(p, create); + AOwner.Add2AutoFree(p); + p.fControl := c; + p.fFont := NewFont; + p.fControl.Font.Assign(p.fFont); + p.Font.FontHeight := -8; + p.fControl.Font.FontHeight := -8; + p.fControl.OnChange := p.DoChange; + p.fControl.OnMeasureItem := p.DoMeasureItem; + p.fFilterItems := NewList; + p.fCreated := False; + p.fInitialized := 0; + Result := p; +end; + +function TSPCFilterCombo.SetAlign(Value: TControlAlign): PSPCFilterCombo; +begin + fControl.Align := Value; + Result := @Self; +end; + +procedure TSPCFilterCombo.Add; +begin + fFilterItems.Add(TFilterItem.Create); + TFilterItem(fFilterItems.Items[fFilterItems.Count - 1]).Description := Copy(fNewFilter, 1, Pos('|', fNewFilter) - 1); + TFilterItem(fFilterItems.Items[fFilterItems.Count - 1]).Filter := Copy(fNewFilter, Pos('|', fNewFilter) + 1, Length(fNewFilter) - Pos('|', fNewFilter)); + BuildList; +end; + +procedure TSPCFilterCombo.DeleteItem; +begin + fFilterItems.Delete(Index); +end; + +function TSPCFilterCombo.Count: Integer; +begin + Result := fFilterItems.Count; +end; + +function TSPCFilterCombo.GetFilterItem; +begin + Result := fFilterItems.Items[Index]; +end; + +procedure TSPCFilterCombo.Update; +begin + DoChange(@Self); +end; + +procedure TSPCFilterCombo.DoChange(Obj: PObj); +begin + Filter := TFilterItem(fFilterItems.Items[fControl.CurIndex]).Filter; + if Assigned(fOnChange) then fOnChange(@Self); + if Assigned(fFileListBox) then fFileListBox.Filters := Filter; +end; + +destructor TSPCFilterCombo.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCFilterCombo.SetPosition(X, Y: integer): PSPCFilterCombo; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCFilterCombo.SetSize(X, Y: integer): PSPCFilterCombo; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCFilterCombo.GetFont; +begin + Result := fFont; + fControl.Color := $FFFFFF; +end; + +procedure TSPCFilterCombo.SetFont(Value: PGraphicTool); +begin + fFont := Value; +end; + +procedure TSPCFilterCombo.BuildList; +var + i : Integer; +begin + fControl.Color := Color; + fControl.Font.Assign(Font); + fControl.Clear; + if fFilterItems.Count > 0 then + for i := 1 to fFilterItems.Count do fControl.Add(TFilterItem(fFilterItems.Items[i - 1]).Description); +end; + +procedure TSPCFilterCombo.SetFilter(Value: string); +begin + fFilter := Value; + if Assigned(fOnChange) then fOnChange(@Self); +end; + +procedure TSPCFilterCombo.SetCurIndex(Value: Integer); +begin + fCurIndex := Value; + fControl.CurIndex := Value; + Inc(fInitialized); + if fInitialized > 2 then fInitialized := 2; + if Assigned(fOnChange) then if fInitialized = 2 then fOnChange(@Self); +end; + +function TSPCFilterCombo.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCFilterCombo.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCFilterCombo.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCFilterCombo.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCFilterCombo.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCFilterCombo.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCFilterCombo.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCFilterCombo.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +function TSPCFilterCombo.DoMeasureItem(Sender: PObj; Idx: Integer): Integer; +begin + Result := 16; +end; + +function TSPCFilterCombo.GetItem(Index: Integer): string; +begin + Result := fControl.Items[Index]; +end; + +procedure TSPCFilterCombo.SetItem(Index: Integer; Value: string); +begin + if Index + 1 > fFilterItems.Count then fFilterItems.Add(TFilterItem.Create); + TFilterItem(fFilterItems.Items[Index]).Description := Copy(Value, 1, Pos('|', Value) - 1); + TFilterItem(fFilterItems.Items[Index]).Filter := Copy(Value, Pos('|', Value) + 1, Length(Value) - Pos('|', Value)); + BuildList; +end; + +function TSPCFilterCombo.GetFilter: string; +begin + Result := TFilterItem(fFilterItems.Items[fControl.CurIndex]).Filter; +end; + +function TSPCFilterCombo.GetCurIndex: Integer; +begin + Result := fControl.CurIndex; +end; + +{ TSPCStatus } + +function NewTSPCStatusBar; +var + p : PSPCStatus; + c : PControl; + Style : DWord; +begin + Style := $00000000; + Style := Style or WS_VISIBLE or WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; //msctls_statusbar32 + c := _NewControl(AOwner, PChar('msctls_statusbar32'), Style, True, nil); + // c:=_NewStatusBar(AOwner); + c.Style := Style; + c.ExStyle := c.ExStyle xor WS_EX_CLIENTEDGE; + c.BringToFront; + New(p, create); + p.fControl := c; + Result := p; +end; + +destructor TSPCStatus.Destroy; +begin + fFont.Free; + inherited; +end; + +function TSPCStatus.SetAlign(Value: TControlAlign): PSPCStatus; +begin + fControl.Align := Value; + Result := @Self; +end; + +function TSPCStatus.SetPosition(X, Y: integer): PSPCStatus; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TSPCStatus.SetSize(X, Y: integer): PSPCStatus; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TSPCStatus.GetFont; +begin + Result := fControl.Font; +end; + +procedure TSPCStatus.SetFont(Value: PGraphicTool); +begin + fControl.Font.Assign(Value); +end; + +function TSPCStatus.GetHeight: Integer; +begin + Result := fControl.Height; +end; + +procedure TSPCStatus.SetHeight(Value: Integer); +begin + fControl.Height := Value; +end; + +function TSPCStatus.GetWidth: Integer; +begin + Result := fControl.Width; +end; + +procedure TSPCStatus.SetWidth(Value: Integer); +begin + fControl.Width := Value; +end; + +function TSPCStatus.GetTop: Integer; +begin + Result := fControl.Top; +end; + +procedure TSPCStatus.SetTop(Value: Integer); +begin + fControl.Top := Value; +end; + +function TSPCStatus.GetLeft: Integer; +begin + Result := fControl.Left; +end; + +procedure TSPCStatus.SetLeft(Value: Integer); +begin + fControl.Left := Value; +end; + +procedure TSPCStatus.SetSimpleStatusText(Value: string); +begin + fControl.Caption := Value; +end; + +function TSPCStatus.GetSimpleStatusText: string; +begin + Result := fControl.Caption; +end; + +end. + diff --git a/Addons/KOLEcmListEdit.pas b/Addons/KOLEcmListEdit.pas new file mode 100644 index 0000000..7d58eb1 --- /dev/null +++ b/Addons/KOLEcmListEdit.pas @@ -0,0 +1,955 @@ +unit KOLEcmListEdit; +{$DEFINE rbutton_sel} +{* TKOLEcmListEdit - расширение стандартного ListView возможностью редактирования +|================================================================================= +| Version 1.17 +|Copyright (C) by ECM, 2004..2006 +|This unit conains objects TEcmListEdit. +|
+  Принцип:        ListEdit "жестко" переводится в lvsDetail(lvsDetailNoHeader) и по DBLCLICK либо
+                  по Enter или по "редактируемому" символу с клавиатуры
+                  (либо программно  StartEdit)переводится в режим
+                  "редактирования" - сверху на текущаю строку ListEdit накладывается
+                  "встроенный редактор" (по-умолчанию EditBox)
+                  В этом режиме можно перемещать фокус ввода между ячейками почти
+                  как в StringGrid-е. Выход из режима редактирования - Esc, StopEdit
+                  или смена фокуса
+
+  Это конечно не KOLmdvXLGrid - но "по весу" значительно легче ( ~3.9 кБ)
+
+  Прототип(Идея): KOLListEdit - Александр Шахайло - thanks! (Код переписан заново
+                  практически полностью)
+  Плюсы по сравнению с прототипом (KOLListEdit):
+
+  - Внешний вид более приближен к StringGrid за счет отсутсвия у встроенного
+  редактора рамки и более точного выравнивания  редактора внутри ячейки (см. OnColAdjust);
+
+  - Автоматический скроллинг ListView в режиме редактирования (как по вертикали
+  так и по горизонтали)+ перемещение между ячейками по горизонтали стрелками влево-вправо;
+
+  - Дополнительные события: OnGetEditText,OnPutEditText,OnStopEdit,OnEditChar,
+  OnColAdjust,OnCreateEdit
+
+  позволяющие настроить поведение встроенного редактора и получить новую функциональность
+|
+} + +// Version 1.17 (29.06.2006) +// Исправлен баг установки Align для Inplace Editor - спасибо Matveev Dmitry +// Добавлено событие OnDrawCell (by Matveev Dmitry) +// Подсветка всей строки теперь только при lvoRowSelect = True +// Исправлена ошибка перехода в режим редактирования по нажатию Ctrl - спасибо Matveev Dmitry + +// Version 1.16 (27.02.2006) +// Несколько исправлений в коде потери-получения фокуса ввода + +// Version 1.15 (3.1.2006) +// Адаптация кода по $DEFINE USE_PROP всвязи с изменениями в KOL.PAS(лучше поздно чем никогда!) + +// Version 1.14 (19.10.2005) +// МСК: Dcr-файл переименован и ссылка на него перенесена из pas-зеркала в +// dpk-файлы + +// Version 1.13 (2.10.2005) +// Добавлено свойство AutoHide в TOnCreateEdit +// AutoHide = True (default) - автоматически закрывает Inplace Editor +// при потере ячейкой фокуса ввода. False - оставляет его открытым + +// Version 1.12 (14.07.2005) +// Добавлена функция WndProcListViewWOResizeFlicks + +// Version 1.11 (24.01.2005) +// Убраны лишние прокрутки при вызове SetCurLVPos +// thanx Sphinxx for bugreport + +// Version 1.10 (18.01.2005) +// При вызове DrawText добавлен атрибут DT_NOPREFIX + +// Version 1.09 (24.12.2004) +// [+] Добавлена функция UpdateRow + +// Version 1.08 (17.11.2004) +// [-] Исправлена установка цвета фона для встроенного редактора. (Где-то +// глюк в зеркале для ListView - в испекторе Color = clWindow а реально +// после создания он получается другим ) + +// Version 1.07 (25.10.2004) +// [+] Добавлена подсветка текущей линии (Переделан метод LVDrawItem - старый +// закомментировал - если надо можно самостоятельно восстановить старый) +// [-] Исправлена ошибка неверной отрисовки - после смены текущей строки при +// помощи клавиатуры и последующей смене фокуса +// [-] Исправлен метод InternalStopEdit (by Dmitry Matveev) +// [*] Несколько мелких изменений (в основном изменение области видимости +// разных функций) + +// Version 1.06 (4.10.2004) +// [*] Коррекция всвязи с выходом KOL 1.96 - теперь NO_ITEMHEIGHT не нужен + +// Version 1.05 (28.09.2004) +// [+] Добавил в OnCreateEdit параметр ReadOnly. При установке его в True +// редактор не создается (by Matveev Dmitry) +// [+] DEFINE NO_ITEMHEIGHT - для отключения кода регулирующего высоту строк +// (необходимо установливать здесь и в зеркале если используется версия +// KOL 1.95+ - в ней управление высотой встроено в ListView) +// Патч KOL+MCK от 1.95 до версии 1.95+ исправляющий ситуацию с установкой +// высоты строк для ListView лежит здесь http://kolibdb.100free.com/kolmck195Plus.zip + +// Version 1.04 (16.09.2004) +// [+] Добавил возможность установки lvsDetailNoHeader (by Matveev Dmitry) + +// Version 1.03 (15.09.2004) +// [-] Убрал "наползание" внешних контролов на заголовок при прокрутке ScrollBar-ом +// [*] Убрал смену активной ячейки при кликах на пустых местах списка (by Matveev Dmitry) + +// Version 1.02 (14.09.2004) +// [*] Оптимизировал отрисовку - меньше лишних миганий +// [+] Упорядочил поведение при смене фокуса +// [*] Оптимизировал выравнивание в ячейке встроенного редактора теперь +// (по крайней мере для taLeft) настраивать Indent в OnColAdjust нет необходимости +// [+] Добавил событие OnCreateEdit - теперь можно попробовать лепить вместо "встроенного" +// EditBox-а - другие контролы (пока проверил на CheckBox и ComboBox) +// Пример использования в демке ... Экспериментальная фича - могут быть +// проблемы... :( + +// Version 1.01 (10.09.2004) +// [+] Сделал режим отрисовки OwnerDraw - получилось почти точная копия VCL-StringGrid +// (в режиме FixedCols = 0 ; Options= [..,goEditing,goDrawFocusSelect,..]) +// В этом режиме почти отпала необходимость корректировать ColOptions.Indent - InPlaceEditor +// по-умолчанию будет попадать точно на тоже место что и строки в ListView +// (по крайней мере для столбцов taLeft. +// [+] Добавил возможность устанавливать высоту строк(Только для варианта OwnerDraw) +// устанавливается в дополнительном параметре NewEcmListEdit, в MCK - ItemHeight +// [+] StartEdit теперь происходит еще и при WM_CHAR (кроме Enter) на ListView-е /by SeM/ +// [*] Много мелких исправлений + +// Version 1.00 (6.09.2004) +// Первая реализация +// +{$I KOLDEF.INC} +//{$DEFINE _LE_DEBUG_} + +interface + +uses + Windows, Messages, KOL; + +type + PEditorOptions = ^TEditorOptions; + TEditorOptions = packed record + Indent: TRect; + TextAlign: TTextAlign; + Options: TEditOptions; + end; + + TOnEditText = procedure(Sender: PControl; ACol, ARow: Integer; var Value: string) of object; + TOnEditChar = procedure(Sender: PControl; ACol, ARow: Integer; var Key: KOLChar; Shift: DWORD) of object; + TOnEndEdit = procedure(Sender: PControl; ACol, ARow: Integer; CellChanged: Boolean) of object; + TOnCreateEdit = procedure(Sender: PControl; ACol: Integer; var Editor: PControl; var ReadOnly: Boolean; var AutoHide: Boolean) of object; + TOnColAdjust = procedure(Sender: PControl; ACol: Integer; var ColOption: TEditorOptions) of object; + TOnDrawCell = function(Sender: PObj; DC: HDC; const Rect: TRect; ACol, ARow: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean of object; + + PEcmListEdit = ^TEcmListEdit; + TEcmListEdit = object(TObj) + {* TEcmListEdit реализует всю функциональность KOLEcmListEdit. +|

+ KOLEcmListEdit создается при помощи NewEcmListEdit, которая пристраивает + TEcmListEdit к свойству KOLEcmListEdit.CustomObj и подключает новый обработчик + событий. Поэтому для доступа к TEcmListEdit в необходимо использовать такую + конструкцию: +! PEcmListEdit(KOLEcmListEdit1.CustomObj) + в MCK это генерируется автоматически. +|

+} + private + fOnCreateEd: TOnCreateEdit; + FOnDrawCell: TOnDrawCell; + procedure EditOnKeyDown(Sender: PControl; var Key: Longint; Shift: DWORD); + procedure EditOnChar(Sender: PControl; var Key: KOLChar; Shift: DWORD); + procedure SetCurIdx(const Value: Integer); + protected + fOwner: PControl; + fColOptions: PList; + fCurIdx: Integer; + fCurLine: Integer; + fScroll: Integer; + fOnPutText: TOnEditText; + fOnGetText: TOnEditText; + fOnEndEdit: TOnEndEdit; + FOnColAdjust: TOnColAdjust; + fStarted: Boolean; + fOnEditChar: TOnEditChar; + fShift: Integer; + fEmbedEd: Boolean; + fAutoHide: Boolean; + function NewInPlaceEd(Options: TEditOptions; Align: TTextAlign): PControl; + procedure DestroyInPlaceEditor; + procedure SetEditPos; + procedure LoadEditValues; + function GetLVItemAtPos(Pt: TSmallPoint; var SubItem: Integer): Integer; + procedure DoColAdjust(ColCount: Integer); + procedure InternalStopEdit(const Store: Boolean); + procedure HideInplaceEd(ActivateOwner: Boolean); + function LVDrawItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean; + procedure ComboBox_CloseUp(Sender: PObj); + public + fInPlaceEd: PControl; + bComboEditor: Boolean; + ComboOptions: TComboOptions; + ComboText: string; + destructor Destroy; virtual; // Do not call this destructor. Use Free method instead. + procedure SetCurLVPos(ALine, AIdx: Integer); + procedure StartEdit; + {* +|

+ Переводит объект в состояние редактирования Editing=True. Встроенный + редактор появляется на текущей (LVCurItem) строке списка. + Если в списке нет выбранной строки (LVCurItem=-1), автоматически + выбирается первая(0) строка списка ListView. + Вызывается автоматически при DblClick-е мышкой или по клавише Enter. + Можно вызвать программно: +! PEcmListEdit(KOLEcmListEdit1.CustomObj).StartEdit + +|

+ } + procedure StopEdit(Store: Boolean); + {* +|

+ Выводит объект из состояние редактирования Editing=False. + Параметр Store определяет будут ли сохраняться данные из + встроенного редактора в ListView. + Вызывается автоматически при нажатии клавиши Esc (Store=False), + смене фокуса (в режиме OwnerDraw!) + Можно вызвать программно: +! PEcmListEdit(KOLEcmListEdit1.CustomObj).StopEdit(True) +|

+ } + procedure SelectCell(ACol, ARow: Integer); + {* Подсвечивает текущую ячейку } + procedure UpdateRow(ARow: Integer); + {* Перерисовка (Invalidate) указанной строки } + property Editing: Boolean read fStarted; + {* True - встроенный редактор активен. } + property OnGetEditText: TOnEditText read fOnGetText write fOnGetText; + {* Вызывается при загрузке текста во встроенный редактор. (Отдельно + для кажого столбца). } + property OnPutEditText: TOnEditText read fOnPutText write fOnPutText; + {* Вызывается при выгрузке текста из встроенного редактора. (Отдельно + для кажого столбца). } + property OnStopEdit: TOnEndEdit read fOnEndEdit write fOnEndEdit; + {* Вызывается при смене строки редактирования и при выполнении StopEdit. } + property OnEditChar: TOnEditChar read fOnEditChar write fOnEditChar; + {* Вызывается при получении встроенным редактором событий WM_CHAR. Может + использоваться для фильрации ввода} +//--------------------------------------------------------------------------- + property OnColAdjust: TOnColAdjust read FOnColAdjust write fOnColAdjust; + {* +|

+ Вызывается при создании встроенного редактора. (Отдельно для каждого + столбца). Используется для задания парметров редактора. + +|

+} + property CurIdx: Integer read fCurIdx write SetCurIdx; + {* +|

+ Устанавливает фокус на указанный столбец. +|

+} + property OnCreateEdit: TOnCreateEdit read fOnCreateEd write fOnCreateEd; + {* Вызывается при создании редактора ячейки. Может использоваться для + перекрытия встроенного EditBox-а другими компонентами. } + + property OnDrawCell: TOnDrawCell read FOnDrawCell write FOnDrawCell; + {* +|

+ Позволяет реализовать собственную отрисовку ячеек (Не в режиме редактирования) + Вызывается отдельно для каждой ячейки. Если обработчик возвращает False - ячейка + рисуется стандартно. +|

+} + end; + // mck class + TKOLEcmListEdit = PControl; + +function NewEcmListEdit(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; ImageListSmall, ImageListNormal, ImageListState: PImageList): PControl; +function WndProcEcmListEdit(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +function WndProcListViewWOResizeFlicks(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; + +implementation + +const + LEN_COL_ADJUST = WM_USER + 223; + +{$IFDEF _LE_DEBUG_} +procedure AddLog(Addr: Pointer; const S: string); +var + TS: TSystemTime; + SS: String; +begin + GetSystemTime(TS); + SS := Format(' %2d:%.2d:%.2d:%.3d | %.8x ', [TS.wHour, TS.wMinute, TS.wSecond, TS.wMilliseconds, Integer(Addr)]); + LogFileOutput('.\LE_Log.txt', SS + S); +end; +{$ENDIF} + +function WndProcEcmListEdit(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var + R: TRect; + NMhdr: PNMHdr; + NewLine: Integer; + NewCurIdx: Integer; +begin + Result := False; + with PEcmListEdit(Sender.CustomObj)^ do begin + case Msg.message of + LVM_INSERTCOLUMNA, LVM_INSERTCOLUMNW, LVM_DELETECOLUMN: + PostMessage(Msg.hwnd, LEN_COL_ADJUST, 0, 0); + + LEN_COL_ADJUST: + DoColAdjust(Sender.LVColCount); + + WM_LBUTTONDOWN{$IFDEF rbutton_sel}, WM_RBUTTONDOWN{$ENDIF}: + begin + NewLine := GetLVItemAtPos(TSmallPoint(Msg.lParam), NewCurIdx); + SetCurLVPos(NewLine, NewCurIdx); + Sender.Focused := True; + Result := True; + end; + + WM_LBUTTONDBLCLK{$IFDEF rbutton_sel}, WM_RBUTTONDBLCLK{$ENDIF}: + begin + NewLine := GetLVItemAtPos(TSmallPoint(Msg.lParam), NewCurIdx); + SetCurLVPos(NewLine, NewCurIdx); + if (NewLine <> -1) and (NewCurIdx <> -1) then StartEdit; + Sender.Tabstop := False; + Result := True; + end; + + WM_KEYDOWN: + begin + if (Msg.WParam = VK_RETURN) then + StartEdit + else begin + case Msg.WParam of + VK_LEFT, VK_RIGHT: + begin + SetCurLVPos(Sender.LVCurItem, fCurIdx + Msg.wParam - 38); + Result := True; + end; + end; + SetEditPos; + end; + //fInPlaceEd.Click; //.DroppedDown := True; + end; + + // by SeM + WM_CHAR: + if (GetKeyState(VK_CONTROL) >= 0) then begin // ! by Matveev Dmitry + case Msg.wParam of + VK_ESCAPE, VK_RETURN, VK_TAB: + ; + else begin + StartEdit; + Sender.Tabstop := False; + if Assigned(fInPlaceEd) then + PostMessage(fInPlaceEd.Handle, Msg.message, Msg.wParam, Msg.lParam); + Result := True; + end; + end; + end; + + WM_NCPAINT, WM_PAINT: + begin +{$IFDEF _LE_DEBUG_} + AddLog(Sender, 'ListEdit:WM_PAINT'); +{$ENDIF} + SetEditPos(); + end; + +// WM_ERASEBKGND: begin +// Result := True; +// end; + + // Какая-то бяка с прорисовкой сетки в режиме lvoGridLines при использовании + // темы XP - при прокрутке ScrollBar(только кнопками "вверх","вниз") происходит + // лишняя прорисовка линий - в результате некотрые строки получаются перечеркнутыми + // Этот "маразм" позволяет слегка подправить ситуацию + // Если кто знает как поправить - напишите мне ... + WM_VSCROLL: + begin + if (Msg.wParam = SB_ENDSCROLL) then begin + InvalidateRect(fOwner.Handle, nil, True); + UpdateWindow(fOwner.Handle); + end; + end; + WM_NOTIFY: + begin + NMHdr := Pointer(Msg.lParam); + case NMHdr.code of + NM_KILLFOCUS: + begin +{$IFDEF _LE_DEBUG_} + AddLog(Sender, 'ListEdit:NM_KILLFOCUS'); +{$ENDIF} + R := fOwner.ClientRect; + InvalidateRect(fOwner.Handle, @R, False); //UpdateRow(fCurLine); + end; + NM_SETFOCUS: + begin +{$IFDEF _LE_DEBUG_} + AddLog(Sender, 'ListEdit:NM_SETFOCUS'); +{$ENDIF} + //SetCurLVPos(fOwner.LVCurItem,fCurIdx); + end; + LVN_ITEMCHANGED: + begin +{$IFDEF _LE_DEBUG_} + AddLog(Sender, 'ListEdit:LVN_ITEMCHANGED'); +{$ENDIF} + if (fCurLine <> fOwner.LVCurItem) then SetCurLVPos(fOwner.LVCurItem, fCurIdx); + end; + end; + end; + end; + end; +end; + +//by Matveev Dmitry +function WndProcInPlaceEd(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var + pLE: PEcmListEdit; +begin + Result := False; + case Msg.message of + WM_KEYDOWN: + begin + if Msg.wParam = VK_ESCAPE then + PEcmListEdit(Sender.Parent.CustomObj).StopEdit(False); + end; + WM_KILLFOCUS: + begin + pLE := PEcmListEdit(Sender.Parent.CustomObj); + if not Assigned(pLE) then Exit; + with pLE^ do if (fEmbedEd and fAutoHide) then begin + InternalStopEdit(True); + HideInPlaceEd(True); + end; + end; + // D[u]fa + WM_CHAR: + if (Msg.wParam = VK_RETURN) then begin + Msg.message := WM_KILLFOCUS; + WndProcInPlaceEd(Sender, Msg, Rslt); + Result := True; + end; + end; +end; + +// Позволяет в некорых случаях избавиться от лишнего "мограния" при изменении +// размеров. Может использоваться для стандартного KOLListView. +// Для применения после создания ListView-а (ListEdit-а) необходимо присоединить +// данную функцию вызовом ListViewXXX.AttachProc(@WndProcListViewWOResizeFlicks); +function WndProcListViewWOResizeFlicks(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var + rUnder: TRect; + rRight: TRect; + rClient: TRect; +begin + Result := False; + if (Msg.message = WM_ERASEBKGND) then begin + rClient := Sender.ClientRect; + if (Sender.LVCount > 0) then begin + rUnder := Sender.LVSubItemRect(Sender.LVCount - 1, 0); + rUnder.Top := rUnder.Bottom; + rUnder.Bottom := rClient.Bottom; + rRight.Left := rUnder.Right; + rRight.Right := rClient.Right; + rRight.Top := rClient.Top; + rRight.Bottom := rClient.Bottom; + FillRect(Msg.wParam, rRight, Sender.Canvas.Brush.Handle); + end else + rUnder := rClient; + FillRect(Msg.wParam, rUnder, Sender.Canvas.Brush.Handle); + Result := True; + end; +end; + +// PEcmListEdit + +function NewEcmListEdit; +var + pLD: PEcmListEdit; + mOpt: TListViewOptions; +begin + mOpt := Options + [lvoHideSel, lvoOwnerDrawFixed]; + if ((Style <> lvsDetail) and (Style <> lvsDetailNoHeader)) then Style := lvsDetail; + Result := NewListView(AParent, Style, mOpt, ImageListSmall, ImageListNormal, ImageListState); + New(pLD, Create); + pLD.fOwner := Result; + pLD.fEmbedEd := False; + pLD.fColOptions := NewList; + pLD.fCurLine := -1; + Result.CustomObj := pLD; + Result.OnDrawItem := pLD.LVDrawItem; + Result.AttachProc(WndProcEcmListEdit); + Result.AttachProc(WndProcListViewWOResizeFlicks); //beta, но на глаз супер +end; + +destructor TEcmListEdit.Destroy; +begin + InternalStopEdit(False); + fColOptions.Release; + inherited; +end; + +procedure TEcmListEdit.ComboBox_CloseUp(Sender: PObj); +begin + StopEdit(True); +end; + +procedure TEcmListEdit.EditOnKeyDown(Sender: PControl; var Key: Longint; Shift: DWORD); +begin + if (fScroll <> 0) then + PostMessage(fOwner.Handle, LVM_SCROLL, fScroll, 0); + case key of +// VK_RETURN: +// StoreEditValues; +// VK_ESCAPE: StopEdit(False); + VK_UP, VK_DOWN: + begin + SetCurLVPos(fCurLine + (Key - 39), fCurIdx); + Key := 0; + end; + VK_LEFT: + if (Sender.SelStart = 0) and (Sender.SelLength = 0) and (fCurIdx > 0) then begin + SetCurLVPos(fCurLine, fCurIdx - 1); + Key := 0; + end; + VK_RIGHT: + if (Sender.SelStart = Length(Sender.Text)) and (fCurIdx < fOwner.LVColCount - 1) then begin + SetCurLVPos(fCurLine, fCurIdx + 1); + Key := 0; + end; + end; +end; + +procedure TEcmListEdit.DestroyInPlaceEditor; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'DestroyInPlaceEditor'); +{$ENDIF} + if fEmbedEd and Assigned(fInPlaceEd) then + fInPlaceEd.Free; + fInPlaceEd := nil; +end; + +procedure TEcmListEdit.SetEditPos; +var + R, Re: TRect; + cw: Integer; + pEO: PEditorOptions; + Header: THandle; + HeaderHeight: Integer; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'SetEditPos'); +{$ENDIF} + with fOwner^ do begin + R := LVSubItemRect(LVCurItem, fCurIdx); + cw := LVColWidth[fCurIdx]; + R.Right := R.Left + cw; + if Assigned(fInPlaceEd) then begin + Header := Perform(LVM_GETHEADER, 0, 0); + GetWindowRect(Header, Re); + HeaderHeight := Re.Bottom - Re.Top; + if R.Top >= HeaderHeight then begin + if fEmbedEd and (fInPlaceEd.Perform(EM_GETRECT, 0, Integer(@Re)) > 0) then begin + if (R.Bottom - R.Top) > (Re.Bottom - Re.Top) then begin + cw := ((R.Bottom - R.Top) - (Re.Bottom - Re.Top)) div 2; + Inc(R.Top, cw); + Dec(R.Bottom, cw); + end; + Inc(R.Left, fShift - Re.Left); + Dec(R.Right, fShift - Re.Left); + end; + pEO := fColOptions.Items[fCurIdx]; + with pEO.Indent do begin + Inc(R.Left, Left); + Dec(R.Right, Right); + Inc(R.Top, Top); + Dec(R.Bottom, Bottom); + // + if fEmbedEd then + Dec(R.Left, 2); + end; + end else + FillChar(R, SizeOf(R), 0); + fInPlaceEd.BoundsRect := R; + end; + if (R.Left <= 0) then + fScroll := R.Left + else if (R.Right > fOwner.Width - 24) then + fScroll := R.Right - (fOwner.Width - 24) + else + fScroll := 0; + end; +end; + +procedure TEcmListEdit.LoadEditValues; +var + S: string; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'LoadEditValues'); +{$ENDIF} + with fOwner^ do begin + S := fOwner.LVItems[LVCurItem, fCurIdx]; + if Assigned(fOnGetText) then + fOnGetText(fOwner, fCurIdx, LVCurItem, S); + if bComboEditor then begin + fInPlaceEd.CurIndex := fInPlaceEd.IndexOf(S); + bComboEditor := False; // + //fInPlaceEd.DroppedDown := True; + end else begin //if fEmbedEd then begin + if (fInPlaceEd.SubClassName = 'obj_COMBOBOX') then + fInPlaceEd.CurIndex := fInPlaceEd.IndexOf(S) + else begin // 'obj_EDIT' + fInPlaceEd.Text := S; + fInPlaceEd.SelectAll; + end; + end; + end; +end; + +procedure TEcmListEdit.StartEdit; +var + pEO: PEditorOptions; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'StartEdit'); +{$ENDIF} + if (fOwner.LVColCount = 0) or (fOwner.LVCount = 0) or fStarted or (fCurIdx = -1) then Exit; + fCurLine := fOwner.LVCurItem; + if (fCurLine = -1) then begin + fCurLine := 0; + fOwner.LVCurItem := 0; + end; + //CreateInPlaceEditor(fOwner.LVColCount); + if not fStarted then begin + DestroyInPlaceEditor; + if (fOwner.LVColCount > 0) then begin + pEO := fColOptions.Items[fCurIdx]; + fInPlaceEd := NewInPlaceEd(pEO.Options, pEO.TextAlign); + end; + end; + if Assigned(fInPlaceEd) then begin + fStarted := True; + SetEditPos; + LoadEditValues; + fOwner.Tabstop := False; + fInPlaceEd.Visible := True; + fInPlaceEd.Focused := True; + UpdateRow(fCurLine); + end; +end; + +procedure TEcmListEdit.StopEdit(Store: Boolean); +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'StopEdit: ' + Int2Str(Integer(Store))); +{$ENDIF} + InternalStopEdit(Store); + HideInPlaceEd(True); +end; + +function TEcmListEdit.GetLVItemAtPos(Pt: TSmallPoint; var SubItem: Integer): Integer; +var + HTI: TLVHitTestInfo; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'GetLVItemAtPos: ' + Int2Str(SubItem)); +{$ENDIF} + HTI.pt.x := Pt.X; + HTI.pt.y := Pt.Y; + fOwner.Perform(LVM_SUBITEMHITTEST, 0, Integer(@HTI)); + Result := HTI.iItem; + SubItem := HTI.iSubItem; +end; + +procedure TEcmListEdit.EditOnChar(Sender: PControl; var Key: KOLChar; Shift: DWORD); +begin + case Key of + #13: + begin + StopEdit(True); + Key := #0 + end; + end; + if Assigned(fOnEditChar) then begin + case Key of + #08: // BackSpace! - всегда обрабатывать + else + fOnEditChar(fInPlaceEd, fCurIdx, fOwner.LVCurItem, Key, Shift); + end; + end; +end; + +function TEcmListEdit.NewInPlaceEd(Options: TEditOptions; Align: TTextAlign): PControl; +var + RO: Boolean; + AH: Boolean; +begin + Result := nil; + RO := False; + AH := True; + if Assigned(fOnCreateEd) then + fOnCreateEd(fOwner, fCurIdx, Result, RO, AH); + if not RO then begin + fEmbedEd := not Assigned(Result); + if fEmbedEd then begin + if bComboEditor then begin + Result := NewCombobox(fOwner, ComboOptions); + Result.OnCloseUp := ComboBox_CloseUp; + repeat + Result.Add(Parse(ComboText, ';')); + until (Length(ComboText) = 0); + end else + Result := NewEditBox(fOwner, Options); + Result.Font.Assign(fOwner.Font); + Result.Color := fOwner.LVTextBkColor; + Result.ExStyle := Result.ExStyle and not (WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); + Result.OnKeyDown := EditOnKeyDown; + Result.AttachProc(WndProcInPlaceEd); //by Matveev Dmitry + end else begin + Result.Parent := fOwner; + //Result.Focused := True; + Result.Visible := True; + end; + //Result.Tabstop := True; + fAutoHide := AH; + Result.OnChar := EditOnChar; + Result.TabOrder := fOwner.TabOrder; + Result.TextAlign := Align; + end; +end; + +function TEcmListEdit.LVDrawItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean; +var + fBr: HBRUSH; + cBr: TColor; + i: Integer; + S: String; + P: TPoint; + R: TRect; + dt: DWORD; + pEO: PEditorOptions; +begin + with fOwner^ do begin + fShift := 0; + for i := 0 to LVColCount - 1 do begin + R := LVSubItemRect(ItemIdx, i); + P := LVItemPos[i]; + if (i = 0) then begin + R.Right := R.Left + LVColWidth[0]; + fShift := P.X - R.Left + 2; + end; + if (Perform(LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0) and LVS_EX_GRIDLINES) <> 0 then begin + Inc(R.Left); + Dec(R.Bottom); + end; + if Assigned(FOnDrawCell) then + if FOnDrawCell(Sender, DC, R, i, ItemIdx, DrawAction, ItemState) then Continue; //by Matveev Dmitry + + if fOwner.Enabled then + cBr := fOwner.LVTextBkColor + else + cBr := clBtnFace; + + if (ItemIdx = fCurLine) then begin + if (fOwner.Focused or (Assigned(fInPlaceEd) and fInPlaceEd.Visible)) and Enabled then begin + if (i = fCurIdx) then begin + if fStarted then + cBr := fOwner.LVTextBkColor + else + cBr := clHighlight; + SetTextColor(DC, Color2RGB(clHighlightText)); + end else begin + if (Perform(LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0) and LVS_EX_FULLROWSELECT) <> 0 then + cBr := $F3E6CD; + SetTextColor(DC, Color2RGB(fOwner.Font.Color)); + end + end else begin + SetTextColor(DC, Color2RGB(fOwner.Font.Color)); + if Enabled then begin + if (i = fCurIdx) then begin + if fStarted then + cBr := fOwner.LVTextBkColor + else + cBr := clInactiveBorder; + end else begin + cBr := $F0F0F0; + end + end; + end; + end else + SetTextColor(DC, Color2RGB(fOwner.Font.Color)); + + fBr := CreateSolidBrush(Color2RGB(cBr)); + FillRect(DC, R, fBr); + DeleteObject(fBr); + + if not ((ItemIdx = LVCurItem) and (fStarted) and (i = fCurIdx)) then begin + S := fOwner.LVItems[ItemIdx, i]; + dt := DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX; + + if (fColOptions.Count <> LVColCount) then + DoColAdjust(LVColCount); + pEO := fColOptions.Items[i]; + case pEO.TextAlign of + taRight: + dt := dt or DT_RIGHT; + taCenter: + dt := dt or DT_CENTER; + end; + Dec(R.Right, fShift); + Inc(R.Left, fShift); + DrawText(DC, @S[1], Length(S), R, dt); + end; + end; + end; + Result := True; +end; + +procedure TEcmListEdit.DoColAdjust(ColCount: Integer); +var + i: Integer; + pEO: PEditorOptions; +begin + if (ColCount <> fColOptions.Count) then begin + for i := fColOptions.Count - 1 downto 0 do // downto - for what? + FreeMem(fColOptions.Items[i]); + fColOptions.Clear; + + for i := 0 to ColCount - 1 do begin + New(pEO); + ZeroMemory(pEO, SizeOf(TEditorOptions)); + pEO.TextAlign := fOwner.LVColAlign[i]; + if Assigned(fOnColAdjust) then + fOnColAdjust(fOwner, i, pEO^); + fColOptions.Add(pEO); + end; + end; +end; + +procedure TEcmListEdit.SetCurLVPos(ALine, AIdx: Integer); +var + NewIdx: Integer; +begin +// NewIdx := AIdx; + with fOwner^ do begin +// if (ALine = LVCurItem) and (AIdx = fCurIdx) then Exit; +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'SetCurLVPos: ' + Int2Str(ALine) + ',' + Int2Str(AIdx)); +{$ENDIF} + if (AIdx >= 0) and (AIdx < LVColCount) and (ALine >= 0) and (ALine < LVCount) then + NewIdx := AIdx + else + NewIdx := fCurIdx; + InternalStopEdit(True); + + fCurIdx := NewIdx; + if (ALine >= 0) and (ALine < LVCount) then begin + if ALine <> LVCurItem then begin + NewIdx := LVCurItem; + LVCurItem := ALine; + UpdateRow(NewIdx); + end; + fCurLine := LVCurItem; + end; + HideInPlaceEd(True); + SetEditPos; + if (fScroll <> 0) then + PostMessage(Handle, LVM_SCROLL, fScroll, 0); + + if (ALine <> -1) then + PostMessage(Handle, LVM_ENSUREVISIBLE, fCurLine, 0); + + UpdateRow(fCurLine); + end; +end; + +procedure TEcmListEdit.InternalStopEdit(const Store: Boolean); +var + s: String; + fCellChanged: Boolean; +begin + if fStarted then begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'InternalStopEdit: ' + Int2Str(Integer(Store))); +{$ENDIF} + fCellChanged := False; + if Store then begin + with fOwner^ do begin + if (fOwner.LVItems[LVCurItem, fCurIdx] <> fInPlaceEd.Text) then begin + S := fInPlaceEd.Text; + if Assigned(fOnPutText) then + fOnPutText(fOwner, fCurIdx, LVCurItem, S); + if (S <> fOwner.LVItems[LVCurItem, fCurIdx]) then begin + fCellChanged := True; + fOwner.LVItems[LVCurItem, fCurIdx] := S; + end; + fInPlaceEd.Text := S; + end; + end; + end; + fStarted := False; + if Assigned(fOnEndEdit) then + fOnEndEdit(fOwner, fCurIdx, fOwner.LVCurItem, fCellChanged); + end; +end; + +procedure TEcmListEdit.HideInplaceEd(ActivateOwner: Boolean); +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'HideInplaceEd: ' + Int2Str(Integer(ActivateOwner))); +{$ENDIF} + if Assigned(fInPlaceEd) then begin +// fInPlaceEd.Tabstop := False; + fOwner.TabOrder := fInPlaceEd.TabOrder; + {if ActivateOwner then }fOwner.Focused := True; + fOwner.Tabstop := True; + fInPlaceEd.Visible := False; + UpdateRow(fCurLine); + //fOwner.Invalidate; + end; + //if fInPlaceEd <> nil then DestroyInPlaceEditor(); +end; + +procedure TEcmListEdit.SetCurIdx(const Value: Integer); +begin + fOwner.Focused := True; + SetCurLVPos(fOwner.LVCurItem, Value); +end; + +procedure TEcmListEdit.SelectCell(ACol, ARow: Integer); +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'SelectCell: ' + Int2Str(ACol) + ',' + Int2Str(ARow)); +{$ENDIF} + fOwner.Focused := True; + SetCurLVPos(ARow, ACol); +end; + +procedure TEcmListEdit.UpdateRow(ARow: Integer); +var + R: TRect; +begin +{$IFDEF _LE_DEBUG_} + AddLog(Self.fOwner, 'UpdateRow": ' + Int2Str(ARow)); +{$ENDIF} + R := fOwner.LVSubItemRect(ARow, 0); + InvalidateRect(fOwner.Handle, @R, False); +end; + +end. + diff --git a/Addons/KOLEdb.pas b/Addons/KOLEdb.pas new file mode 100644 index 0000000..4744adc --- /dev/null +++ b/Addons/KOLEdb.pas @@ -0,0 +1,2209 @@ +unit KOLEdb; +{* This unit is created for KOL to allow to communicate with DB using OLE DB. +|
======================================================================== +|
Copyright (C) 2001 by Vladimir Kladov. +|

+ This unit conains three objects TDataSource, TSession and TQuery to implement + the most important things: to connect to database, to control transactions, + to perform commands (queries) and obtain results or update tables. +|

+} + +interface + +uses Windows, ActiveX, KOL, err; + +type + INT64 = I64; + PInt64 = PI64; + + tagVariant = packed Record + vt: WORD; + reserved1, + reserved2, + reserved3: WORD; + case Integer of + 0: ( bVal : Byte ); + 1: ( iVal : ShortInt ); + 2: ( lVal : Integer ); + 3: ( fltVal : Extended ); + 4: ( dblVal : Double ); + 5: ( boolVal : Bool ); + 6: ( scode : SCODE ); + //7: ( cyVal : CY ); + //8: ( date : Date ); + 9: ( bstrVal : Pointer ); // BSTR => [ Len: Integer; array[ 1..Len ] of WideChar ] + 10:( pdecVal : ^Decimal ); + end; + +(* +typedef struct tagVARIANT { + VARTYPE vt; + unsigned short wReserved1; + unsigned short wReserved2; + unsigned short wReserved3; + union { + Byte bVal; // VT_UI1. + Short iVal; // VT_I2. + long lVal; // VT_I4. + float fltVal; // VT_R4. + double dblVal; // VT_R8. + VARIANT_BOOL boolVal; // VT_BOOL. + SCODE scode; // VT_ERROR. + CY cyVal; // VT_CY. + DATE date; // VT_DATE. + BSTR bstrVal; // VT_BSTR. + DECIMAL FAR* pdecVal // VT_BYREF|VT_DECIMAL. + IUnknown FAR* punkVal; // VT_UNKNOWN. + IDispatch FAR* pdispVal; // VT_DISPATCH. + SAFEARRAY FAR* parray; // VT_ARRAY|*. + Byte FAR* pbVal; // VT_BYREF|VT_UI1. + short FAR* piVal; // VT_BYREF|VT_I2. + long FAR* plVal; // VT_BYREF|VT_I4. + float FAR* pfltVal; // VT_BYREF|VT_R4. + double FAR* pdblVal; // VT_BYREF|VT_R8. + VARIANT_BOOL FAR* pboolVal; // VT_BYREF|VT_BOOL. + SCODE FAR* pscode; // VT_BYREF|VT_ERROR. + CY FAR* pcyVal; // VT_BYREF|VT_CY. + DATE FAR* pdate; // VT_BYREF|VT_DATE. + BSTR FAR* pbstrVal; // VT_BYREF|VT_BSTR. + IUnknown FAR* FAR* ppunkVal; // VT_BYREF|VT_UNKNOWN. + IDispatch FAR* FAR* ppdispVal; // VT_BYREF|VT_DISPATCH. + SAFEARRAY FAR* FAR* pparray; // VT_ARRAY|*. + VARIANT FAR* pvarVal; // VT_BYREF|VT_VARIANT. + void FAR* byref; // Generic ByRef. + char cVal; // VT_I1. + unsigned short uiVal; // VT_UI2. + unsigned long ulVal; // VT_UI4. + int intVal; // VT_INT. + unsigned int uintVal; // VT_UINT. + char FAR * pcVal; // VT_BYREF|VT_I1. + unsigned short FAR * puiVal; // VT_BYREF|VT_UI2. + unsigned long FAR * pulVal; // VT_BYREF|VT_UI4. + int FAR * pintVal; // VT_BYREF|VT_INT. + unsigned int FAR * puintVal; //VT_BYREF|VT_UINT. + }; +}; +*) + +{============= This part of code is grabbed from OLEDB.pas ================} +const + MAXBOUND = 65535; { High bound for arrays } + DBSTATUS_S_ISNULL = $00000003; + +type + PIUnknown = ^IUnknown; + PUintArray = ^TUintArray; + TUintArray = array[0..MAXBOUND] of UINT; + + HROW = UINT; + PHROW = ^HROW; + PPHROW = ^PHROW; + + HACCESSOR = UINT; + HCHAPTER = UINT; + DBCOLUMNFLAGS = UINT; + DBTYPE = Word; + DBKIND = UINT; + DBPART = UINT; + DBMEMOWNER = UINT; + DBPARAMIO = UINT; + DBBINDSTATUS = UINT; + +const + IID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}'; + IID_IDataInitialize : TGUID = '{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'; + CLSID_MSDAINITIALIZE: TGUID = '{2206CDB0-19C1-11D1-89E0-00C04FD7A829}'; + + IID_IDBInitialize : TGUID = '{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'; + //IID_IDBProperties : TGUID = '{0C733A8A-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IDBCreateSession: TGUID = '{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IDBCreateCommand: TGUID = '{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommand : TGUID = '{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommandText : TGUID = '{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommandProperties: TGUID = '{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowset : TGUID = '{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowsetChange : TGUID = '{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowsetUpdate : TGUID = '{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IColumnsInfo : TGUID = '{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IAccessor : TGUID = '{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'; + + // Added By ECM !!! ================================================== + IID_ITransaction : TGUID = '{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'; + IID_ITransactionLocal: TGUID = '{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ITransactionOptions: TGUID = '{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'; + // =================================================================== + + // for version 1.5 of OLE DB: + //DBGUID_DBSQL : TGUID = '{c8b522df-5cf3-11ce-ade5-00aa0044773d}'; + + // otherwise: + DBGUID_DBSQL : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; + DBGUID_DEFAULT : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; + DBGUID_SQL : TGUID = '{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}'; + + DBPROPSET_ROWSET : TGUID = '{C8B522BE-5CF3-11CE-ADE5-00AA0044773D}'; + + DB_S_ENDOFROWSET = $00040EC6; + +type + +// *********************************************************************// +// Interface: IDBInitialize +// GUID: {0C733A8B-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBInitialize = interface(IUnknown) + ['{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'] + function Initialize: HResult; stdcall; + function Uninitialize: HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IDBCreateCommand +// GUID: {0C733A1D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBCreateCommand = interface(IUnknown) + ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] + function CreateCommand(const punkOuter: IUnknown; const riid: TGUID; + out ppCommand: IUnknown): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDBCreateCommandSC = interface(IUnknown) + ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure CreateCommand(const punkOuter: IUnknown; const riid: TGUID; + out ppCommand: IUnknown); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: IDBCreateSession +// GUID: {0C733A5D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBCreateSession = interface(IUnknown) + ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] + function CreateSession(const punkOuter: IUnknown; const riid: TGUID; + out ppDBSession: IUnknown): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDBCreateSessionSC = interface(IUnknown) + ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure CreateSession(const punkOuter: IUnknown; const riid: TGUID; + out ppDBSession: IUnknown); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: IDataInitialize +// GUID: {2206CCB1-19C1-11D1-89E0-00C04FD7A829} +// *********************************************************************// + IDataInitialize = interface(IUnknown) + ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] + function GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; + pwszInitializationString: POleStr; const riid: TIID; + var DataSource: IUnknown): HResult; stdcall; + function GetInitializationString(const DataSource: IUnknown; + fIncludePassword: Boolean; out pwszInitString: POleStr): HResult; stdcall; + function CreateDBInstance(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + riid: TIID; var DataSource: IUnknown): HResult; stdcall; + function CreateDBInstanceEx(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI): HResult; stdcall; + function LoadStringFromStorage(pwszFileName: POleStr; + out pwszInitializationString: POleStr): HResult; stdcall; + function WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; + dwCreationDisposition: DWORD): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDataInitializeSC = interface(IUnknown) + ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] + procedure GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; + pwszInitializationString: POleStr; const riid: TIID; + var DataSource: IUnknown); safecall; + procedure GetInitializationString(const DataSource: IUnknown; + fIncludePassword: Boolean; out pwszInitString: POleStr); safecall; + procedure CreateDBInstance(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + riid: TIID; var DataSource: IUnknown); safecall; + procedure CreateDBInstanceEx(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI); safecall; + procedure LoadStringFromStorage(pwszFileName: POleStr; + out pwszInitializationString: POleStr); safecall; + procedure WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; + dwCreationDisposition: DWORD); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: ICommand +// GUID: {0C733A63-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ICommand = interface(IUnknown) + ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] + function Cancel: HResult; stdcall; + function Execute(const punkOuter: IUnknown; const riid: TGUID; + pParams: Pointer; // var pParams: DBPARAMS; + pcRowsAffected: PInteger; ppRowset: PIUnknown): HResult; stdcall; + function GetDBSession(const riid: TGUID; out ppSession: IUnknown): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandSC = interface(IUnknown) + ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] + procedure Cancel; safecall; + procedure Execute(const punkOuter: IUnknown; const riid: TGUID; var pParams: DBPARAMS; + pcRowsAffected: PInteger; ppRowset: PIUnknown); safecall; + procedure GetDBSession(const riid: TGUID; out ppSession: IUnknown); safecall; + end; + *) + +// *********************************************************************// +// Interface: ICommandText +// GUID: {0C733A27-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ICommandText = interface(ICommand) + ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] + function GetCommandText(var pguidDialect: TGUID; + out ppwszCommand: PWideChar): HResult; stdcall; + function SetCommandText(rguidDialect: PGUID; + pwszCommand: PWideChar): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandTextSC = interface(ICommand) + ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetCommandText(var pguidDialect: TGUID; + out ppwszCommand: PWideChar); safecall; + procedure SetCommandText(rguidDialect: PGUID; + pwszCommand: PWideChar); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowset +// GUID: {0C733A7C-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IRowset = interface(IUnknown) + ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] + function AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; + rgRowStatus: PUintArray): HResult; stdcall; + function GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; + out pcRowsObtained: UINT; {var prghRows: PUintArray} prghRows: Pointer ): HResult; stdcall; + function ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, + rgRefCounts, rgRowStatus: PUintArray): HResult; stdcall; + function RestartPosition(hReserved: HCHAPTER): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetSC = interface(IUnknown) + ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] + procedure AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; + rgRowStatus: PUintArray); safecall; + procedure GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; + out pcRowsObtained: UINT; var prghRows: PUintArray); safecall; + procedure ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, + rgRefCounts, rgRowStatus: PUintArray); safecall; + procedure RestartPosition(hReserved: HCHAPTER); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowsetChange +// GUID: {0C733A05-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IRowsetChange = interface(IUnknown) + ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] + function DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgRowStatus: PUintArray): HResult; stdcall; + function SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; + phRow: PHROW): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetChangeSC = interface(IUnknown) + ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] + procedure DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgRowStatus: PUintArray); safecall; + procedure SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; + phRow: PHROW); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowsetUpdate +// GUID: {0C733A6D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + DBPENDINGSTATUS = DWORD; + PDBPENDINGSTATUS = ^DBPENDINGSTATUS; + PPDBPENDINGSTATUS = ^PDBPENDINGSTATUS; + + DBROWSTATUS = UINT; + PDBROWSTATUS = ^DBROWSTATUS; + PPDBROWSTATUS = ^PDBROWSTATUS; + + IRowsetUpdate = interface(IRowsetChange) + ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] + function GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; + prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS): HResult; stdcall; + function GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgPendingStatus: PUintArray): HResult; stdcall; + function Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; + prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; + function Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; + prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetUpdateSC = interface(IRowsetChange) + ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; + prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS); safecall; + procedure GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgPendingStatus: PUintArray); safecall; + procedure Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; + prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; + procedure Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; + prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; + end; + *) + +// *********************************************************************// +// Interface: ICommandProperties +// GUID: {0C733A79-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + + DBPROPID = UINT; + PDBPROPID = ^DBPROPID; + PDBPropIDArray = ^TDBPropIDArray; + TDBPropIDArray = array[0..MAXBOUND] of DBPROPID; + + PDBIDGuid = ^TDBIDGuid; + DBIDGUID = record + case Integer of + 0: (guid: TGUID); + 1: (pguid: ^TGUID); + end; + TDBIDGuid = DBIDGUID; + + PDBIDName = ^TDBIDName; + DBIDNAME = record + case Integer of + 0: (pwszName: PWideChar); + 1: (ulPropid: UINT); + end; + TDBIDName = DBIDNAME; + + DBPROPOPTIONS = UINT; + DBPROPSTATUS = UINT; + PPDBID = ^PDBID; + PDBID = ^DBID; + DBID = packed record + uGuid: DBIDGUID; + eKind: DBKIND; + uName: DBIDNAME; + end; + TDBID = DBID; + + PDBProp = ^TDBProp; + DBPROP = packed record + dwPropertyID: DBPROPID; + dwOptions: DBPROPOPTIONS; + dwStatus: DBPROPSTATUS; + colid: DBID; + vValue: tagVariant; // OleVariant; + end; + TDBProp = DBPROP; + + PDBPropArray = ^TDBPropArray; + TDBPropArray = array[0..MAXBOUND] of TDBProp; + + PPDBPropSet = ^PDBPropSet; + PDBPropSet = ^TDBPropSet; + DBPROPSET = packed record + rgProperties: PDBPropArray; + cProperties: UINT; + guidPropertySet: TGUID; + end; + TDBPropSet = DBPROPSET; + + PDBPropIDSet = ^TDBPropIDSet; + DBPROPIDSET = packed record + rgPropertyIDs: PDBPropIDArray; + cPropertyIDs: UINT; + guidPropertySet: TGUID; + end; + TDBPropIDSet = DBPROPIDSET; + + PDBPropIDSetArray = ^TDBPropIDSetArray; + TDBPropIDSetArray = array[0..MAXBOUND] of TDBPropIDSet; + + PDBPropSetArray = ^TDBPropSetArray; + TDBPropSetArray = array[0..MAXBOUND] of TDBPropSet; + + ICommandProperties = interface(IUnknown) + ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] + function GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; + var pcPropertySets: UINT; out prgPropertySets: PDBPropSet): HResult; stdcall; + function SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandPropertiesSC = interface(IUnknown) + ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; + var pcPropertySets: UINT; out prgPropertySets: PDBPropSet); safecall; + procedure SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray); safecall; + end; + *) + + PDBIDArray = ^TDBIDArray; + TDBIDArray = array[0..MAXBOUND] of TDBID; + + PDBColumnInfo = ^TDBColumnInfo; + DBCOLUMNINFO = packed record + pwszName: PWideChar; + pTypeInfo: ITypeInfo; + iOrdinal: UINT; + dwFlags: DBCOLUMNFLAGS; + ulColumnSize: UINT; + wType: DBTYPE; + bPrecision: Byte; + bScale: Byte; + columnid: DBID; + end; + TDBColumnInfo = DBCOLUMNINFO; + + PColumnInfo = ^TColumnInfoArray; + TColumnInfoArray = array[ 0..MAXBOUND ] of TDBColumnInfo; + +// *********************************************************************// +// Interface: IColumnsInfo +// GUID: {0C733A11-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IColumnsInfo = interface(IUnknown) + ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] + function GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; + out ppStringsBuffer: PWideChar): HResult; stdcall; + function MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; + rgColumns: PUintArray): HResult; stdcall; + end; + + (* + { Safecall Version } + IColumnsInfoSC = interface(IUnknown) + ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; + out ppStringsBuffer: PWideChar); safecall; + procedure MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; + rgColumns: PUINTArray); safecall; + end; + *) + + PDBBindExt = ^TDBBindExt; + DBBINDEXT = packed record + pExtension: PByte; + ulExtension: UINT; + end; + TDBBindExt = DBBINDEXT; + + PDBObject = ^TDBObject; + DBOBJECT = packed record + dwFlags: UINT; + iid: TGUID; + end; + TDBObject = DBOBJECT; + + PDBBinding = ^TDBBinding; + DBBINDING = packed record + iOrdinal: UINT; + obValue: UINT; + obLength: UINT; + obStatus: UINT; + pTypeInfo: Pointer; //ITypeInfo; (reserved, should be nil) + pObject: PDBObject; + pBindExt: PDBBindExt; + dwPart: DBPART; + dwMemOwner: DBMEMOWNER; + eParamIO: DBPARAMIO; + cbMaxLen: UINT; + dwFlags: UINT; + wType: DBTYPE; + bPrecision: Byte; + bScale: Byte; + end; + TDBBinding = DBBINDING; + + PDBBindingArray = ^TDBBindingArray; + TDBBindingArray = array[0..MAXBOUND] of TDBBinding; + +const + DBTYPE_EMPTY = $00000000; + DBTYPE_NULL = $00000001; + DBTYPE_I2 = $00000002; + DBTYPE_I4 = $00000003; + DBTYPE_R4 = $00000004; + DBTYPE_R8 = $00000005; + DBTYPE_CY = $00000006; + DBTYPE_DATE = $00000007; + DBTYPE_BSTR = $00000008; + DBTYPE_IDISPATCH = $00000009; + DBTYPE_ERROR = $0000000A; + DBTYPE_BOOL = $0000000B; + DBTYPE_VARIANT = $0000000C; + DBTYPE_IUNKNOWN = $0000000D; + DBTYPE_DECIMAL = $0000000E; + DBTYPE_UI1 = $00000011; + DBTYPE_ARRAY = $00002000; + DBTYPE_BYREF = $00004000; + DBTYPE_I1 = $00000010; + DBTYPE_UI2 = $00000012; + DBTYPE_UI4 = $00000013; + DBTYPE_I8 = $00000014; + DBTYPE_UI8 = $00000015; + DBTYPE_FILETIME = $00000040; + DBTYPE_GUID = $00000048; + DBTYPE_VECTOR = $00001000; + DBTYPE_RESERVED = $00008000; + DBTYPE_BYTES = $00000080; + DBTYPE_STR = $00000081; + DBTYPE_WSTR = $00000082; + DBTYPE_NUMERIC = $00000083; + DBTYPE_UDT = $00000084; + DBTYPE_DBDATE = $00000085; + DBTYPE_DBTIME = $00000086; + DBTYPE_DBTIMESTAMP = $00000087; + DBTYPE_DBFILETIME = $00000089; + DBTYPE_PROPVARIANT = $0000008A; + DBTYPE_VARNUMERIC = $0000008B; + +type +// *********************************************************************// +// Interface: IAccessor +// GUID: {0C733A8C-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IAccessor = interface(IUnknown) + ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] + function AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; + function CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; + cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray): HResult; stdcall; + function GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; + out prgBindings: PDBBinding): HResult; stdcall; + function ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; + end; + + (* + { Safecall Version } + IAccessorSC = interface(IUnknown) + ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] + procedure AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; + procedure CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; + cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray); safecall; + procedure GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; + out prgBindings: PDBBinding); safecall; + procedure ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; + end; + *) + +// Begin Added By ECM !!! ======================================================= + PBoid = ^TBoid; + BOID = packed record + rgb_: array[0..15] of Byte; + end; + TBoid = BOID; + + PXactTransInfo = ^TXactTransInfo; + XACTTRANSINFO = packed record + uow: BOID; + isoLevel: Integer; + isoFlags: UINT; + grfTCSupported: UINT; + grfRMSupported: UINT; + grfTCSupportedRetaining: UINT; + grfRMSupportedRetaining: UINT; + end; + TXactTransInfo = XACTTRANSINFO; + + PXactOpt = ^TXactOpt; + XACTOPT = packed record + ulTimeout: UINT; + szDescription: array[0..39] of Shortint; + end; + TXActOpt = XACTOPT; + +// *********************************************************************// +// Interface: ITransactionOptions +// GUID: {3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD} +// *********************************************************************// + ITransactionOptions = interface(IUnknown) + ['{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'] + function SetOptions(var pOptions: XACTOPT): HResult; stdcall; + function GetOptions(var pOptions: XACTOPT): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: ITransaction +// GUID: {0FB15084-AF41-11CE-BD2B-204C4F4F5020} +// *********************************************************************// + ITransaction = interface(IUnknown) + ['{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'] + function Commit(fRetaining: BOOL; grfTC: UINT; grfRM: UINT): HResult; stdcall; + function Abort(pboidReason: PBOID; fRetaining: BOOL; fAsync: BOOL): HResult; stdcall; + function GetTransactionInfo(out pinfo: XACTTRANSINFO): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: ITransactionLocal +// GUID: {0C733A5F-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ITransactionLocal = interface(ITransaction) + ['{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'] + function GetOptionsObject(out ppOptions: ITransactionOptions): HResult; stdcall; + function StartTransaction(isoLevel: Integer; isoFlags: UINT; + const pOtherOptions: ITransactionOptions; pulTransactionLevel: PUINT): HResult; stdcall; + end; + +const + XACTTC_SYNC_PHASEONE = $00000001; + XACTTC_SYNC_PHASETWO = $00000002; + XACTTC_SYNC = $00000002; + XACTTC_ASYNC_PHASEONE = $00000004; + XACTTC_ASYNC = $00000004; + +// End Added By ECM !!! ========================================================= + +// Begin Added By azsd !!! ====================================================== +(* +type + PDbNumeric = ^tagDB_NUMERIC; + tagDB_NUMERIC = packed record + precision: Byte; + scale: Byte; + sign: Byte; + val: array[0..15] of Byte; + end; +*) +// End Added By azsd !!! ======================================================== + +{============= This part of code is designed by me ================} +type + PDBBINDSTATUSARRAY = ^TDBBINDSTATUSARRAY; + TDBBINDSTATUSARRAY = array[ 0..MAXBOUND ] of DBBINDSTATUS; + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TDataSource - a connection to data base +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + PDataSource = ^TDataSource; + TDataSource = object( TObj ) + {* This object provides a connection with data base. You create it using + NewDataSource function and passing a connection string to it. The object + is initializing immediately after creating. You can get know if the + connection established successfully reading Intitialized property. } + private + fSessions: PList; + fIDBInitialize: IDBInitialize; + FInitialized: Boolean; + protected + function Initialize( const Params: String ): Boolean; + public + constructor Create; + {* Do not call this constructor. Use function NewDataSource instead. } + destructor Destroy; virtual; + {* Do not call this destructor. Use Free method instead. When TDataSource + object is destroyed, all its sessions (and consequensly, all queries) + are freed automatically. } + property Initialized: Boolean read FInitialized; + {* Returns True, if the connection with database is established. Mainly, + it is not necessary to analizy this flag. If any error occure during + initialization, CheckOle halts further execution. (But You can use + another error handler, which does not stop the application). } + end; + +function NewDataSource( const Params: String ): PDataSource; +{* Creates data source objects and initializes it. Pass a connection + string as a parameter, which determines used provider, database + location, user identification and other parameters. See demo provided + or/and read spicifications from database software vendors, which + parameters to pass. } + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TSession - transaction session in a connection +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + PSession = ^TSession; + TSession = object( TObj ) + {* This object is intended to provide session transactions. It always + must be created as a "child" of TDataSource object, and it owns by + query objects (of type TQuery). For each TDataSource object, it is + possible to create several TSession objects, and for each session, + several TQuery objects can exist. } + private + fQueryList: PList; + fDataSource: PDataSource; + fCreateCommand: IDBCreateCommand; + + // Added By ECM !!! ================== + fTransaction: ITransaction; + fTransactionLocal: ITransactionLocal; + // =================================== + + protected + public + constructor Create; + {* } + destructor Destroy; virtual; + {* Do not call directly, call Free method instead. When TSession object is + destroyed, all it child queries are freed automatically. } + + // Added By ECM !!! ==================================== + function StartTransaction(isoLevel: Integer): HRESULT; + function Commit(Retaining: BOOL): HRESULT; + function Rollback(Retaining: BOOL): HRESULT; + function Active: Boolean; + // ===================================================== + + property DataSource: PDataSource read fDataSource; + {* Returns a pointer to owner TDataSource object. } + end; + +function NewSession( ADataSource: PDataSource ): PSession; +{* Creates session object owned by ADataSource (this last must exist). } + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TQuery - a command and resulting rowset(s) +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + TRowsetMode = ( rmUpdateImmediate, rmUpdateDelayed, rmReadOnly ); + TFieldType = ( ftInteger, ftReal, ftString, ftDate, ftLargeInt, ftOther ); + + PQuery = ^TQuery; + TQuery = object( TObj ) + {* This is the most important object to work with database. It is always + must be created as a "child" of TSession object, and allows to perform + commands, open rowsets, scroll it, update and so on. } + private + fSession: PSession; + fText: String; + fCommand: ICommandText; + fCommandProps: ICommandProperties; + fRowsAffected: Integer; + fRowSet: IRowset; + fRowSetChg: IRowsetChange; + fRowSetUpd: IRowsetUpdate; + fColCount: UINT; + fColInfo: PColumnInfo; + fColNames: PWideChar; + fBindings: PDBBindingArray; + fBindStatus: PDBBINDSTATUSARRAY; + fRowSize: Integer; + fAccessor: HACCESSOR; + fRowHandle: THandle; + fRowBuffers: PList; + fEOF: Boolean; + fCurIndex: Integer; + fChanged: Boolean; + fMode: TRowsetMode; + procedure SetText(const Value: String); + function GetRowCount: Integer; + function GetColNames(Idx: Integer): String; + procedure SetCurIndex(const Value: Integer); + function GetRowsKnown: Integer; + function GetStrField(Idx: Integer): String; + procedure SetStrField(Idx: Integer; const Value: String); + function GetIntField(Idx: Integer): Integer; + procedure SetIntField(Idx: Integer; const Value: Integer); + function GetFltField(Idx: Integer): Double; + procedure SetFltField(Idx: Integer; const Value: Double); + function GetDField(Idx: Integer): TDateTime; + procedure SetDField(Idx: Integer; const Value: TDateTime); + function FieldPtr( Idx: Integer ): Pointer; + function Changed( Idx: Integer ): Pointer; + function GetColByName(Name: String): Integer; + function GetSFieldByName(const Name: String): String; + procedure SetSFieldByName(const Name: String; const Value: String); + function GetIFieldByName(const Name: String): Integer; + procedure SetIFieldByName(const Name: String; Value: Integer); + function GetRFieldByName(const Name: String): Double; + procedure SetRFieldByName(const Name: String; const Value: Double); + function GetDFlfByName(const Name: String): TDateTime; + procedure SetDFldByName(const Name: String; const Value: TDateTime); + function GetColType(Idx: Integer): TFieldType; + function GetColTypeByName(const Name: String): TFieldType; + function GetIsNull(Idx: Integer): Boolean; + procedure SetIsNull(Idx: Integer; const Value: Boolean); + function GetIsNullByName(const Name: String): Boolean; + procedure SetIsNullByName(const Name: String; const Value: Boolean); + function GetFByNameAsStr(const Name: String): String; + function GetFieldAsStr(Idx: Integer): String; + procedure SetFByNameFromStr(const Name, Value: String); + procedure SetFieldFromStr(Idx: Integer; const Value: String); + function GetI64Field(Idx: Integer): Int64; + function GetI64FldByName(const Name: String): Int64; + procedure SetI64Field(Idx: Integer; const Value: Int64); + procedure SetI64FldByName(const Name: String; const Value: Int64); + function GetFixupNumeric(Idx: Integer): Int64; //add by azsd + function GetRawType(Idx: Integer): DWORD; + function GetRawTypeByName(const Name: String): DWORD; + function GetFieldAsHex(Idx: Integer): Pointer; + function GetFieldByNameAsHex(const Name: String): Pointer; + protected + fDelList: PList; + procedure ClearRowset; + procedure ReleaseHandle; + procedure FetchData; + procedure NextWOFetch( Skip: Integer ); + public + destructor Destroy; virtual; + {* Do not call the destructor directly, call method Free instead. When + "parent" TSession object is destroyed, all queries owned by the session + are destroyed automatically. } + property Session: PSession read fSession; + {* Returns owner session object. } + property Text: String read FText write SetText; + {* Query command text. When You change it, currently opened rowset (if any) + is closed, so there are no needs to call Close method before preparing + for new command. Current version does not support passing "parameters", + so include all values into Text as a part of string. } + procedure Close; + {* Closes opened rowset if any. It is not necessary to call close after + Execute. Also, rowset is closed automatically when another value is + assigned to Text property. } + procedure Execute; + {* Call this method to execute command (stored in Text), which does not + open a rowset (thus is, "insert", "delete", and "update" SQL statements + do so). } + procedure Open; + {* Call this method for executing command, which opens a rowset (table of + data). This can be "select" SQL statement, or call to stored procedure, + which returns result in a table. } + property RowCount: Integer read GetRowCount; + {* For commands, such as "insert", "delete" or "update" SQL statements, + this property returns number of rows affected by a command. For "select" + statement performed using Open method, this property should return + a number of rows selected. By for (the most) providers, this value is + unknown for first time (-1 is returned). To get know how much rows are + in returned rowset, method Last should be called first. But for large + data returned this is not efficient way, because actually a loop + "while not EOF do Next" is performed to do so. + |
+ Tip: to get count of rows, You can call another query, which executes + "select count(*) where..." SQL statement with the same conditions. } + property RowsKnown: Integer read GetRowsKnown; + {* Returns actual number or selected rows, if this is "known" value, or number + of rows already fetched. } + property ColCount: UINT read fColCount; + {* Returns number of columns in opened rowset. } + property ColNames[ Idx: Integer ]: String read GetColNames; + {* Return names of columns. } + property ColByName[ Name: String ]: Integer read GetColByName; + {* Returns column index by name. Comparing of names is ANSI and case insensitive. } + property ColType[ Idx: Integer ]: TFieldType read GetColType; + {* } + property ColTypeByName[ const Name: String ]: TFieldType read GetColTypeByName; + {* } + function FirstColumn: Integer; + {* by Alexander Shakhaylo. To return an index of the first column, + containing actual data. (for .mdb, the first can contain special + control information, but not for .dbf) } + property RawType[ Idx: Integer ]: DWORD read GetRawType; + {*} + property RawTypeByName[ const Name: String ]: DWORD read GetRawTypeByName; + {*} + property EOF: Boolean read fEOF; + {* Returns True, if end of data is achived (usually after calling Next + or Prev method, or immediately after Open, if there are no rows in opened + rowset). } + procedure First; + {* Resets a position to the start of rowset. This method is called + automatically when Open is called successfully. } + procedure Next; + {* Moves position to the next row if possible. If EOF achived, a position + is not changed. } + procedure Prev; + {* Moves position to a previous row (but if CurIndex > 0). } + procedure Last; + {* Moves position to the last row. This method can be unefficient for + large datasets, because implemented as a loop where method Next is + called repeteadly, while EOF is not achieved. } + property Mode: TRowsetMode read fMode write fMode; + {* } + procedure Post; + {* Applyes changes made in a record, writing changed row to database table. } + procedure Delete; + {* Deletes a row. In rmUpdateDelayed Mode, rows are only added to a list + for later deleting it when Update called. } + procedure Update; + {* Allows to apply all updates far later, not when Post method is called. + To use TQuery in this manner, its Mode should be set to rmUpdateDelayed. } + property CurIndex: Integer read fCurIndex write SetCurIndex; + {* Index of current row. It is possible to change it directly even if + specified row is not yet fetched. But check at least what new value is + stored in CurIndex after such assignment. } + property SField[ Idx: Integer ]: String read GetStrField write SetStrField; + {* Access to a string field by index. You should be sure, that a field + has string type. } + property SFieldByName[ const Name: String ]: String read GetSFieldByName write SetSFieldByName; + {* } + property IField[ Idx: Integer ]: Integer read GetIntField write SetIntField; + {* Access to a integer field by index. You should be sure, that a field + has integer type or compatible. } + property IFieldByName[ const Name: String ]: Integer read GetIFieldByName write SetIFieldByName; + {* } + property LField[ Idx: Integer ]: Int64 read GetI64Field write SetI64Field; + {* } + property LFieldByName[ const Name: String ]: Int64 read GetI64FldByName write SetI64FldByName; + {* } + property RField[ Idx: Integer ]: Double read GetFltField write SetFltField; + {* Access to a real (Double) field by index. You should be sure, that a field + has numeric (with floating decimal point) type. } + property RFieldByName[ const Name: String ]: Double read GetRFieldByName write SetRFieldByName; + {* } + property DField[ Idx: Integer ]: TDateTime read GetDField write SetDField; + {* } + property DFieldByName[ const Name: String ]: TDateTime read GetDFlfByName write SetDFldByName; + {* } + property IsNull[ Idx: Integer ]: Boolean read GetIsNull write SetIsNull; + {* } + property IsNullByName[ const Name: String ]: Boolean read GetIsNullByName write SetIsNullByName; + {* } + property FieldAsStr[ Idx: Integer ]: String read GetFieldAsStr write SetFieldFromStr; + {* } + property FieldByNameAsStr[ const Name: String ]: String read GetFByNameAsStr write SetFByNameFromStr; + {* } + property FieldAsHex[ Idx: Integer ]: Pointer read GetFieldAsHex; + {* Access to field data directly. If you change field data inplace, call + MarkRecordChanged by yourself. If field IsNull, data found at the address + provided have no sense. } + property FieldByNameAsHex[ const Name: String ]: Pointer read GetFieldByNameAsHex; + {* See FieldByNameAsHex. } + procedure MarkFieldChanged( Idx: Integer ); + {* See also MarkRecordChangedByName. } + procedure MarkFieldChangedByName( const Name: String ); + {* When record field changed directly (using FieldAsHex property, for ex.), + use this method to signal to record set container, that record is changed, + and to ensure that field no more marked as null. } + end; + +function NewQuery( Session: PSession ): PQuery; +{* Creates query object. } + +// Error handling routines: + +function CheckOLE( Rslt: HResult ): Boolean; +function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; +procedure DummyOleError( Result: HResult ); +var OleError: procedure( Result: HResult ) = DummyOleError; + +implementation + +type + PDBNumeric = ^TDBNumeric; + TDBNUMERIC = packed record + precision: Byte; + scale: Byte; + sign: Byte; + val: array[0..15] of Byte; + end; + + PDBVarNumeric = ^TDBVarNumeric; + TDBVARNUMERIC = packed record + precision: Byte; + scale: ShortInt; + sign: Byte; + val: ^Byte; + end; + + PDBDate = ^TDBDate; + TDBDATE = packed record + year: Smallint; + month: Word; + day: Word; + end; + + PDBTime = ^TDBTIME; + TDBTIME = packed record + hour: Word; + minute: Word; + second: Word; + end; + + PDBTimeStamp = ^TDBTimeStamp; + TDBTIMESTAMP = packed record + year: Smallint; + month: Word; + day: Word; + hour: Word; + minute: Word; + second: Word; + fraction: UINT; + end; + +var fIMalloc: IMalloc = nil; + +(* procedure DummyOleError( Result: HResult ); +begin + MsgOK( 'OLE DB error ' + Int2Hex( Result, 8 ) ); + Halt; +end; *) + +procedure DummyOleError( Result: HResult ); +begin + raise Exception.Create( e_Custom, 'OLE DB error ' + Int2Hex( Result, 8 ) ); +end; + +function CheckOLE( Rslt: HResult ): Boolean; +begin + Result := Rslt = 0; + if not Result then + OleError( Rslt ); +end; + +function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; +var I: Integer; +begin + Result := TRUE; + for I := Low( OKResults ) to High( OKResults ) do + if Rslt = OKResults[ I ] then Exit; + Result := FALSE; + OleError( Rslt ); +end; + +{ TDataSource } + +function NewDataSource( const Params: String ): PDataSource; +begin + new( Result, Create ); + Result.Initialize( Params ); +end; + +constructor TDataSource.Create; +var clsid: TCLSID; +begin + inherited; + fSessions := NewList; + //if CheckOLEex( CoInitialize( nil ), [ S_OK, S_FALSE ] ) then + OleInit; + if CheckOLE( CoGetMalloc( MEMCTX_TASK, fIMalloc ) ) then + if CheckOLE( CLSIDFromProgID( 'SQLOLEDB', clsid ) ) then + CheckOLE( CoCreateInstance( clsid, nil, CLSCTX_INPROC_SERVER, + IID_IDBInitialize, fIDBInitialize ) ); +end; + +destructor TDataSource.Destroy; +var I: Integer; +begin + for I := fSessions.Count - 1 downto 0 do + PObj( fSessions.Items[ I ] ).Free; + fSessions.Free; + if Initialized then + CheckOLE( fIDBInitialize.UnInitialize ); + OleUnInit; + inherited; +end; + +function TDataSource.Initialize( const Params: String ): Boolean; +var DI: IDataInitialize; + Unk: IUnknown; +begin + Result := FALSE; + if Initialized then + begin + Result := TRUE; + Exit; + end; + if CheckOLE( CoCreateInstance( CLSID_MSDAINITIALIZE, nil, + CLSCTX_ALL, IID_IDataInitialize, DI ) ) then + if CheckOLE( DI.GetDataSource( nil, CLSCTX_ALL, StringToOleStr( Params ), + IID_IDBInitialize, Unk ) ) then + if CheckOLE( Unk.QueryInterface( IID_IDBInitialize, fIDBInitialize ) ) then + if CheckOLE( fIDBInitialize.Initialize ) then + begin + Result := TRUE; + FInitialized := Result; + end; +end; + +{ TSession } + +function NewSession( ADataSource: PDataSource ): PSession; +var CreateSession: IDBCreateSession; + Unk: IUnknown; +begin + new( Result, Create ); + Result.fDataSource := ADataSource; + ADataSource.fSessions.Add( Result ); + // Modified by ECM !!! =============================================================================== + if CheckOLE( ADataSource.fIDBInitialize.QueryInterface( IID_IDBCreateSession, CreateSession ) ) then begin + CheckOLE( CreateSession.CreateSession( nil, IID_IDBCreateCommand, + IUnknown( Result.fCreateCommand ) ) ); + + Unk := Result.fCreateCommand; + if Assigned(Unk) then begin + CheckOLE(Unk.QueryInterface(IID_ITransaction,Result.fTransaction)); + CheckOLE(Unk.QueryInterface(IID_ITransactionLocal,Result.fTransactionLocal)); + end; + end; + // ================================================================================================= +end; + +// Added By ECM !!! ============================================== +function TSession.Active: Boolean; +var + xinfo: TXactTransInfo; + Ret: HRESULT; +begin + if not Assigned(fTransaction) then Result := FALSE + else begin + FillChar(xinfo,SizeOf(xinfo),0); + Ret := fTransaction.GetTransactionInfo(xinfo); + Result := Ret = S_OK; + CheckOLE(Ret); + end; +end; + +function TSession.Commit(Retaining: BOOL): HRESULT; +begin + Assert(Assigned(fTransaction)); + Result := fTransaction.Commit(Retaining,XACTTC_SYNC,0); + CheckOLE(Result); +end; +// =============================================================== + +constructor TSession.Create; +begin + inherited; + fQueryList := NewList; +end; + +destructor TSession.Destroy; +var I: Integer; +begin + for I := fQueryList.Count - 1 downto 0 do + PObj( fQueryList.Items[ I ] ).Free; + fQueryList.Free; + I := fDataSource.fSessions.IndexOf( @Self ); + fDataSource.fSessions.Delete( I ); + // Add By ECM !!! ================ + // if Active then Rollback(FALSE); + //================================ + fCreateCommand := nil; + inherited; +end; + +// Added By ECM !!! =============================================== +function TSession.Rollback(Retaining: BOOL): HRESULT; +begin + Assert(Assigned(fTransaction)); + Result := fTransaction.Abort(nil,Retaining,FALSE); + CheckOLE(Result); +end; + +function TSession.StartTransaction(isoLevel: Integer): HRESULT; +begin + Assert(Assigned(fTransactionLocal)); + Result := fTransactionLocal.StartTransaction(isoLevel,0,nil,nil); + CheckOLE(Result); +end; +// ================================================================ + +{ TQuery } + +function NewQuery( Session: PSession ): PQuery; +begin + new( Result, Create ); + Result.fSession := Session; + Session.fQueryList.Add( Result ); + CheckOLE( Session.fCreateCommand.CreateCommand( nil, IID_ICommandText, + IUnknown( Result.fCommand ) ) ); +end; + +function TQuery.Changed( Idx: Integer ): Pointer; +begin + fChanged := TRUE; + Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obStatus ); + PDWORD( Result )^ := 0; // set to NOT NULL +end; + +procedure TQuery.ClearRowset; +var I: Integer; + AccessorIntf: IAccessor; +begin + ReleaseHandle; + + if fAccessor <> 0 then + begin + if CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ) then + AccessorIntf.ReleaseAccessor( fAccessor, nil ); + fAccessor := 0; + end; + + if fRowBuffers <> nil then + begin + for I := fRowBuffers.Count - 1 downto 0 do + FreeMem( fRowBuffers.Items[ I ] ); + fRowBuffers.Free; + fRowBuffers := nil; + end; + fRowSize := 0; + + if fBindings <> nil then + begin + //for I := 0 to fColCount - 1 do + // fBindings[ I ].pTypeInfo := nil; + FreeMem( fBindings ); + fBindings := nil; + FreeMem( fBindStatus ); + fBindStatus := nil; + end; + + if fColInfo <> nil then + fIMalloc.Free( fColInfo ); + fColInfo := nil; + + if fColNames <> nil then + fIMalloc.Free( fColNames ); + fColNames := nil; + + fColCount := 0; + fRowSetUpd := nil; + fRowSet := nil; + fRowSetChg := nil; + fRowsAffected := 0; + + fEOF := TRUE; +end; + +procedure TQuery.Close; +begin + Update; + ClearRowset; +end; + +procedure TQuery.Delete; +var Params, Results: array of DWORD; +begin + //if fRowHandle = 0 then Exit; + CASE fMode OF + rmUpdateImmediate: + begin + SetLength( Results, 1 ); + SetLength( Params, 1 ); + Params[ 0 ] := fRowHandle; + CheckOLE( fRowSetUpd.DeleteRows( 0, 1, @ Params[ 0 ], @ Results[ 0 ] ) ); + end; + rmUpdateDelayed: + begin + if fDelList = nil then + fDelList := NewList; + fDelList.Add( Pointer( fRowHandle ) ); + end; + END; +end; + +destructor TQuery.Destroy; +var I: Integer; +begin + Close; //ClearRowset; + I := fSession.fQueryList.IndexOf( @Self ); + if I >= 0 then + fSession.fQueryList.Delete( I ); + fText := ''; + fCommandProps := nil; + fCommand := nil; + fDelList.Free; + inherited; +end; + +procedure TQuery.Execute; +begin + ClearRowset; + // first set txt to fCommand just before execute + if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then + CheckOLE( fCommand.Execute( nil, IID_NULL, nil, @fRowsAffected, nil ) ); +end; + +procedure TQuery.FetchData; +var Buffer: Pointer; +begin + if fRowHandle = 0 then + Exit; + if fRowBuffers.Items[ fCurIndex ] = nil then + begin + GetMem( Buffer, fRowSize ); + FillChar( Buffer^, fRowSize, 0 ); //fixup the varnumberic random bytes by azsd + fRowBuffers.Items[ fCurIndex ] := Buffer; + CheckOLE( fRowSet.GetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ) ); + end; +end; + +function TQuery.FieldPtr(Idx: Integer): Pointer; +begin + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Result := nil + else + Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obValue ); +end; + +procedure TQuery.First; +begin + if fCurIndex = 0 then Exit; + ReleaseHandle; + fCurIndex := -1; + if CheckOLE( fRowSet.RestartPosition( 0 ) ) then + begin + fEOF := FALSE; + Next; + end; +end; + +function TQuery.FirstColumn: Integer; +var i: integer; +begin + Result := -1; + for i := 0 to fColCount - 1 do begin + if fBindings[i].iOrdinal > 0 then begin + Result := i; + exit; + end; + end; +end; + +function TQuery.GetColByName(Name: String): Integer; +var I: Integer; +begin + Result := -1; + for I := 0 to fColCount - 1 do + begin + if AnsiCompareStrNoCase( Name, ColNames[ I ] ) = 0 then + begin + Result := I; + break; + end; + end; +end; + +function TQuery.GetColNames(Idx: Integer): String; +begin + Result := fColInfo[ Idx ].pwszName; +end; + +function TQuery.GetColType(Idx: Integer): TFieldType; +begin + Result := ftOther; + if fBindings = nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_I1, DBTYPE_I2, DBTYPE_I4, DBTYPE_BOOL, + DBTYPE_UI1, DBTYPE_UI2, DBTYPE_UI4 : Result := ftInteger; + DBTYPE_I8, DBTYPE_UI8 : Result := ftLargeInt; + DBTYPE_BSTR, DBTYPE_WSTR, DBTYPE_STR: Result := ftString; + DBTYPE_R4, DBTYPE_R8, DBTYPE_CY, + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, + DBTYPE_DECIMAL : Result := ftReal;// no need new cate here,moved to GetFieldAsStr + DBTYPE_DATE, DBTYPE_FILETIME, //DBTYPE_DBFILETIME, + DBTYPE_DBDATE, DBTYPE_DBTIME, + DBTYPE_DBTIMESTAMP : Result := ftDate; + else Result := ftOther; + end; +end; + +function TQuery.GetColTypeByName(const Name: String): TFieldType; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >= 0, 'Incorrect column name (' + Name + ').' ); + Result := ColType[ Idx ]; +end; + +function TQuery.GetDField(Idx: Integer): TDateTime; +var P: Pointer; + ST: TSystemTime; + pD: PDBDate; + pT: PDBTime; + TS: PDBTimeStamp; + pFT: PFileTime; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0.0 + else + begin + FillChar( ST, Sizeof(ST), 0 ); + case fBindings[ Idx ].wType of + DBTYPE_DATE: Result := PDouble( P )^ + VCLDate0; + DBTYPE_DBDATE: + begin + pD := P; + ST.wYear := pD.year; + ST.wMonth := pD.month; + ST.wDay := pD.day; + SystemTime2DateTime( ST, Result ); + end; + DBTYPE_DBTIME: + begin + pT := P; + ST.wYear := 1899; + ST.wMonth := 12; + ST.wDay := 31; + ST.wHour := pT.hour; + ST.wMinute := pT.minute; + ST.wSecond := pT.second; + SystemTime2DateTime( ST, Result ); + Result := Result - VCLDate0; + end; + DBTYPE_DBTIMESTAMP: + begin + TS := P; + ST.wYear := TS.year; + ST.wMonth := TS.month; + ST.wDay := TS.day; + ST.wHour := TS.hour; + ST.wMinute := TS.minute; + ST.wSecond := TS.second; + ST.wMilliseconds := TS.fraction div 1000000; + SystemTime2DateTime( ST, Result ); + end; + DBTYPE_FILETIME: + begin + pFT := P; + FileTimeToSystemTime( pFT^, ST ); + SystemTime2DateTime( ST, Result ); + end; + else Result := 0.0; + end; + end; +end; + +function TQuery.GetDFlfByName(const Name: String): TDateTime; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := DField[ Idx ]; +end; + +function TQuery.GetFByNameAsStr(const Name: String): String; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := FieldAsStr[ Idx ]; +end; + +function TQuery.GetFieldAsHex(Idx: Integer): Pointer; +begin + {if IsNull[ Idx ] then + Result := nil + else} + Result := FieldPtr( Idx ); +end; + +function TQuery.GetFieldAsStr(Idx: Integer): String; +begin + if IsNull[ Idx ] then + Result := '(null)' + else + case ColType[ Idx ] of + ftReal: + //added optimize by azsd + begin + case fBindings[ Idx ].wType of + DBTYPE_NUMERIC,DBTYPE_VARNUMERIC: + if ShortInt(PDBNumeric(FieldPtr(Idx)).scale)<>0 then + Result := Double2Str( RField[ Idx ] ) + else + Result := Int64_2Str( LField[ Idx ] ); + else + Result := Double2Str( RField[ Idx ] ); + end; + end; + ftString: Result := SField[ Idx ]; + ftDate: Result := DateTime2StrShort( DField[ Idx ] ); + ftLargeInt: Result := Int64_2Str( LField[ Idx ] );//add by azsd + //ftInteger: + else Result := Int2Str( IField[ Idx ] ); + //else Result := '(?)'; + end; +end; + +function TQuery.GetFieldByNameAsHex(const Name: String): Pointer; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := FieldAsHex[ Idx ]; +end; + +function TQuery.GetFltField(Idx: Integer): Double; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0.0 + else + case fBindings[ Idx ].wType of + DBTYPE_R4: Result := PSingle( P )^; + DBTYPE_R8: Result := PDouble( P )^; + DBTYPE_CY: Result := PInteger( P )^ * 0.0001; + //TODO: DBTYPE_DECIMAL + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + Result := Int64_2Double(GetFixupNumeric(Idx)); + if PDBNumeric(P).sign=0 then Result := 0 - Result; + if PDBNumeric(P).scale<>0 then Result := Result * IntPower( 10, 0 - Shortint(PDBNumeric(P).scale)); + end; + else Result := 0.0; + end; +end; + +function TQuery.GetFixupNumeric(Idx: Integer): Int64; +var + P: Pointer; +begin + P := FieldPtr( Idx ); + Result := MakeInt64( 0, 0 ); + if P=nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_NUMERIC: + Result := PInt64( DWORD(P)+3 )^; //131 filled with 00 + DBTYPE_VARNUMERIC: + begin + Result := PInt64( DWORD(P)+3 )^; //139 containing some shit bytes + //vn := P; + //if vn.precision> then + //fix-up done in Fetchdata + end; + else + Result := MakeInt64( PDWORD( DWORD(P)+3 )^, 0 ); + end; +end; + +function TQuery.GetI64Field(Idx: Integer): Int64; +const His: array[ 0..1 ] of Integer = ( 0, -1 and not 255 ); +var P: Pointer; + B: Byte; +begin + P := FieldPtr( Idx ); + Result := MakeInt64( 0, 0 ); + if P <> nil then + case fBindings[ Idx ].wType of + DBTYPE_I8, DBTYPE_UI8, DBTYPE_CY: + Result := PInt64( P )^; + DBTYPE_I1: + begin + B := PByte( P )^; + Result := Int2Int64( Integer( B ) or His[ B shr 7 ] ); + end; + DBTYPE_UI1: Result := MakeInt64( PByte( P )^, 0 ); + DBTYPE_I2: Result := Int2Int64( PShortInt( P )^ ); + DBTYPE_UI2: Result := MakeInt64( PWord( P )^, 0 ); + DBTYPE_I4: Result := Int2Int64( PInteger( P )^ ); + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + if ShortInt(PDBNumeric(P).scale)<>0 then + Result := Double2Int64( RField[Idx] ) + else + Result := GetFixupNumeric(Idx); + end; + //DBTYPE_UI4: + else Result := MakeInt64( PInteger( P )^, 0 ); + end; +end; + +function TQuery.GetI64FldByName(const Name: String): Int64; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := LField[ Idx ]; +end; + +function TQuery.GetIFieldByName(const Name: String): Integer; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := IField[ Idx ]; +end; + +function TQuery.GetIntField(Idx: Integer): Integer; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0 + else + case fBindings[ Idx ].wType of + DBTYPE_I1: begin + Result := PByte( P )^; + if LongBool( Result and $80) then + Result := Result or not $7F; + end; + DBTYPE_UI1: Result := PByte( P )^; + DBTYPE_I2, DBTYPE_UI2, DBTYPE_BOOL: Result := PShortInt( P )^; + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + if ShortInt(PDBNumeric(P).scale)<>0 then + Result := Round( RField[Idx] ) + else + Result := GetFixupNumeric(Idx).Lo; + end; + //DBTYPE_I4, DBTYPE_UI4, DBTYPE_HCHAPTER: + else Result := PInteger( P )^; + end; +end; + +function TQuery.GetIsNull(Idx: Integer): Boolean; +var P: PDWORD; +begin + Result := TRUE; + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Exit; + P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obStatus ); + Result := P^ = DBSTATUS_S_ISNULL; +end; + +function TQuery.GetIsNullByName(const Name: String): Boolean; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := IsNull[ Idx ]; +end; + +function TQuery.GetRawType(Idx: Integer): DWORD; +begin + Result := 0; + if fBindings = nil then Exit; + Result := fBindings[ Idx ].wType; +end; + +function TQuery.GetRawTypeByName(const Name: String): DWORD; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := RawType[ Idx ]; +end; + +function TQuery.GetRFieldByName(const Name: String): Double; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := RField[ Idx ]; +end; + +function TQuery.GetRowCount: Integer; +begin + {if fRowsAffected = DB_S_ASYNCHRONOUS then + begin + // only for asynchronous connections - do not see now + end;} + Result := fRowsAffected; +end; + +function TQuery.GetRowsKnown: Integer; +begin + Result := fRowsAffected; + if Result = 0 then + if fRowBuffers <> nil then + Result := fRowBuffers.Count; +end; + +function TQuery.GetSFieldByName(const Name: String): String; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := SField[ Idx ]; +end; + +function TQuery.GetStrField(Idx: Integer): String; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := '' + else + if fBindings[ Idx ].wType = DBTYPE_STR then + Result := PChar( P ) + else + Result := PWideChar( P ); +end; + +procedure TQuery.Last; +begin + while not EOF do + Next; //WOFetch( 0 ); + if RowsKnown > 0 then + fCurIndex := RowsKnown; + Prev; + //FetchData; + fEOF := FALSE; +end; + +procedure TQuery.MarkFieldChanged(Idx: Integer); +begin + Changed( Idx ); +end; + +procedure TQuery.MarkFieldChangedByName(const Name: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + MarkFieldChanged( Idx ); +end; + +procedure TQuery.Next; +begin + NextWOFetch( 0 ); + FetchData; +end; + +procedure TQuery.NextWOFetch( Skip: Integer ); +var Obtained: UINT; + PHandle: Pointer; + hr: HResult; +begin + ReleaseHandle; + PHandle := @fRowHandle; + if (fCurIndex = fRowsAffected) and (Skip = -2) then + hr := fRowSet.GetNextRows( 0, -1, 1, Obtained, @PHandle ) + else + hr := fRowSet.GetNextRows( 0, Skip, 1, Obtained, @PHandle ); + if hr <> DB_S_ENDOFROWSET then + CheckOLE( hr ); + Inc( fCurIndex, Skip + 1 ); + if Obtained = 0 then + begin + fEOF := TRUE; + if fRowBuffers <> nil then + fRowsAffected := fRowBuffers.Count; + end + else + begin + if fRowBuffers = nil then + fRowBuffers := NewList; + if fCurIndex >= fRowBuffers.Count then + fRowBuffers.Add( nil ); + end; +end; + +procedure TQuery.Open; +const + DB_NULLID: DBID = (uguid: (guid: (D1: 0; D2: 0; D3:0; D4: (0, 0, 0, 0, 0, 0, 0, 0))); + ekind: 1 {DBKIND_GUID_PROPID}; uname: (ulpropid:0)); + +var ColInfo: IColumnsInfo; + AccessorIntf: IAccessor; + I: Integer; + OK: Boolean; + + PropSets: array[0..0] of TDBPropset; + Props: array[ 0..0 ] of TDBProp; +begin + ClearRowset; + if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then + begin + if Mode = rmReadOnly then + begin + if not CheckOLE( fCommand.Execute( nil, IID_IROWSET, nil, @fRowsAffected, PIUnknown( @fRowSet ) ) ) then + Exit; + end + else + begin + // Add by ECM !!! + {$IFNDEF IBPROVIDER} + if fCommandProps = nil then + begin + if CheckOLE( fCommand.QueryInterface( IID_ICommandProperties, fCommandProps ) ) then + begin + PropSets[0].rgProperties := @ Props[ 0 ]; + PropSets[0].cProperties := 1; + PropSets[0].guidPropertySet := DBPROPSET_ROWSET; + + Props[0].dwPropertyID := $00000075; //DBPROP_UPDATABILITY + Props[0].dwOptions := 0; //DBPROPOPTIONS_REQUIRED; + Props[0].dwStatus := 0; //DBPROPSTATUS_OK; + Props[0].colid := DB_NULLID; + Props[0].vValue.vt := VT_I4; + Props[0].vValue.lVal := 1; //DBPROPVAL_UP_CHANGE; + end; + end; + CheckOLE( fCommandProps.SetProperties( 1, @ PropSets[ 0 ] ) ); + {$ENDIF} + if not CheckOLE( fCommand.Execute( nil, IID_IROWSETCHANGE, nil, nil, PIUnknown( @ fRowSetChg ) ) ) then + Exit; + if not CheckOLE( fRowSetChg.QueryInterface( IID_IROWSET, fRowSet ) ) then + Exit; + if Mode = rmUpdateDelayed then + CheckOLE( fRowSetChg.QueryInterface( IID_IROWSETUPDATE, fRowSetUpd ) ); + end; + + if fRowsAffected = 0 then + Dec( fRowsAffected ); // RowCount = -1 means that RowCount is an unknown value + if fRowSetChg <> nil then + begin + OK := CheckOLE( fRowSetChg.QueryInterface( IID_IColumnsInfo, ColInfo ) ); + end + else + begin + OK := CheckOLE( fRowSet.QueryInterface( IID_IColumnsInfo, ColInfo ) ); + end; + if OK then + if CheckOLE( ColInfo.GetColumnInfo( fColCount, PDBColumnInfo( fColInfo ), fColNames ) ) then + begin + fBindings := AllocMem( Sizeof( TDBBinding ) * fColCount); + for I := 0 to fColCount - 1 do + begin + fBindings[ I ].iOrdinal := fColInfo[ I ].iOrdinal; + fBindings[ I ].obValue := fRowSize + 4; + // fBindings[ I ].obLength := 0; + fBindings[ I ].obStatus := fRowSize; + // fBindings[ I ].pTypeInfo := nil; + // fBindings[ I ].pObject := nil; + // fBindings[ I ].pBindExt := nil; + fBindings[ I ].dwPart := 1 + 4; //DBPART_VALUE + DBPART_STATUS; + // fBindings[ I ].dwMemOwner := 0; //DBMEMOWNER_CLIENTOWNED; + // fBindings[ I ].eParamIO := 0; //DBPARAMIO_NOTPARAM; + fBindings[ I ].cbMaxLen := fColInfo[ I ].ulColumnSize; + case fColInfo[ I ].wType of + DBTYPE_BSTR: Inc( fBindings[ I ].cbMaxLen, 1 ); + DBTYPE_WSTR: fBindings[ I ].cbMaxLen := fBindings[ I ].cbMaxLen * 2 + 2; + end; + fBindings[ I ].cbMaxLen := (fBindings[ I ].cbMaxLen + 3) and not 3; + // fBindings[ I ].dwFlags := 0; + fBindings[ I ].wType := fColInfo[ I ].wType; + fBindings[ I ].bPrecision := fColInfo[ I ].bPrecision; + fBindings[ I ].bScale := fColInfo[ I ].bScale; + Inc( fRowSize, fBindings[ I ].cbMaxLen + 4 ); + end; + fBindStatus := AllocMem( Sizeof( DBBINDSTATUS ) * fColCount ); + if fRowSetChg <> nil then + begin + OK := CheckOLE( fRowSetChg.QueryInterface( IID_IAccessor, AccessorIntf ) ); + end + else + begin + OK := CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ); + end; + if OK then + CheckOLE( + AccessorIntf.CreateAccessor( + 2, //DBACCESSOR_ROWDATA, // Accessor will be used to retrieve row data + fColCount, // Number of columns being bound + fBindings, // Structure containing bind info + 0, // Not used for row accessors + fAccessor, // Returned accessor handle + PUIntArray( fBindStatus ) // Information about binding validity + ) + ); + fEOF := FALSE; + fCurIndex := -1; + First; + end; + end; +end; + +procedure TQuery.Post; +var R: HResult; + {P: PChar; + I: Integer;} +begin + if not fChanged then Exit; + if fRowSetChg = nil then Exit; + R := fRowSetChg.SetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ); + if R <> HResult( $00040EDA {DB_S_ERRORSOCCURED} ) then + CheckOLE( R ) + { // я вижу только статус DBSTATUS_E_INTEGRITYVIOLATION касательно 0-й колонки, + // которую никто не просил добавлять во время выборки. + else + begin + asm + int 3 + end; + for I := 0 to fColCount-1 do + begin + P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ I ].obStatus ); + ShowMessage( fColInfo[I].pwszName + '.Status=' + Int2Hex( PDWORD( P )^, 8 ) ); + end; + end}; + fChanged := FALSE; +end; + +procedure TQuery.Prev; +begin + if CurIndex > 0 then + begin + NextWOFetch( -2 ); //*** + //Dec( fCurIndex ); + fEOF := FALSE; + FetchData; //*** + end; +end; + +procedure TQuery.ReleaseHandle; +begin + if fRowHandle <> 0 then + CheckOLE( fRowSet.ReleaseRows( 1, @fRowHandle, nil, nil, nil ) ); + fRowHandle := 0; +end; + +procedure TQuery.SetCurIndex(const Value: Integer); +var OldCurIndex: Integer; +begin + OldCurIndex := fCurIndex; + if fCurIndex = Value then + begin + if fRowHandle = 0 then + FetchData; + if fRowHandle <> 0 then + Exit; + end; + if Value = 0 then + First + else + if Value >= fRowsAffected - 1 then + Last; + + fEOF := FALSE; + while (fCurIndex < Value) and not EOF do + Next; + while (fCurIndex > Value) and not EOF do + Prev; + + if fCurIndex = Value then + FetchData + else + fCurIndex := OldCurIndex; +end; + +procedure TQuery.SetDField(Idx: Integer; const Value: TDateTime); +var P: Pointer; + ST: TSystemTime; + pD: PDBDate; + pT: PDBTime; + TS: PDBTimeStamp; + pFT: PFileTime; +begin + P := FieldPtr( Idx ); + if P = nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_DATE: PDouble( P )^ := Value - VCLDate0; + DBTYPE_DBDATE: + begin + pD := P; + DateTime2SystemTime( Value, ST ); + pD.year := ST.wYear; + pD.month := ST.wMonth; + pD.day := ST.wDay; + end; + DBTYPE_DBTIME: + begin + pT := P; + DateTime2SystemTime( Value, ST ); + pT.hour := ST.wHour; + pT.minute := ST.wMinute; + pT.second := ST.wSecond; + end; + DBTYPE_DBTIMESTAMP: + begin + TS := P; + DateTime2SystemTime( Value, ST ); + TS.year := ST.wYear; + TS.month := ST.wMonth; + TS.day := ST.wDay; + TS.hour := ST.wHour; + TS.minute := ST.wMinute; + TS.second := ST.wSecond; + TS.fraction := ST.wMilliseconds * 1000; + end; + DBTYPE_FILETIME: + begin + pFT := P; + DateTime2SystemTime( Value, ST ); + SystemTimeToFileTime( ST, pFT^ ); + end; + else Exit; + end; + Changed( Idx ); +end; + +procedure TQuery.SetDFldByName(const Name: String; const Value: TDateTime); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + DField[ Idx ] := Value; +end; + +procedure TQuery.SetFByNameFromStr(const Name, Value: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + FieldAsStr[ Idx ] := Value; +end; + +procedure TQuery.SetFieldFromStr(Idx: Integer; const Value: String); +begin + if StrEq( Value, '(null)' ) and (ColType[ Idx ] <> ftString) then + IsNull[ Idx ] := TRUE + else + case ColType[ Idx ] of + ftInteger: IField[ Idx ] := Str2Int( Value ); + ftReal: RField[ Idx ] := Str2Double( Value ); + ftString: SField[ Idx ] := Value; + ftDate: DField[ Idx ] := Str2DateTimeShort( Value ); + end; +end; + +procedure TQuery.SetFltField(Idx: Integer; const Value: Double); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + case fBindings[ Idx ].wType of + DBTYPE_R4: PExtended( P )^ := Value; + DBTYPE_R8: PDouble( P )^ := Value; + DBTYPE_CY: PInteger( P )^ := Round( Value * 10000 ); + //TODO: DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, DBTYPE_DECIMAL + else Exit; + end; + Changed( Idx ); +end; + +procedure TQuery.SetI64Field(Idx: Integer; const Value: Int64); +begin + +end; + +procedure TQuery.SetI64FldByName(const Name: String; const Value: Int64); +begin + +end; + +procedure TQuery.SetIFieldByName(const Name: String; Value: Integer); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + IField[ Idx ] := Value; +end; + +procedure TQuery.SetIntField(Idx: Integer; const Value: Integer); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + case fBindings[ Idx ].wType of + DBTYPE_I1, DBTYPE_UI1: PByte( P )^ := Byte( Value ); + DBTYPE_I2, DBTYPE_UI2: PShortInt( P )^ := Value; + DBTYPE_BOOL: if Value <> 0 then PShortInt( P )^ := -1 + else PShortInt( P )^ := 0; + else PInteger( P )^ := Value; + end; + Changed( Idx ); +end; + +procedure TQuery.SetIsNull(Idx: Integer; const Value: Boolean); +var P: PDWORD; +begin + if not Value then Exit; + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Exit; + P := Changed( Idx ); + P^ := DBSTATUS_S_ISNULL; +end; + +procedure TQuery.SetIsNullByName(const Name: String; const Value: Boolean); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + IsNull[ Idx ] := Value; +end; + +procedure TQuery.SetRFieldByName(const Name: String; const Value: Double); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + RField[ Idx ] := Value; +end; + +procedure TQuery.SetSFieldByName(const Name: String; const Value: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + SField[ Idx ] := Value; +end; + +procedure TQuery.SetStrField(Idx: Integer; const Value: String); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + if fBindings[ Idx ].wType = DBTYPE_STR then + StrLCopy( PChar( P ), @ Value[ 1 ], fBindings[ Idx ].cbMaxLen ) + else + StringToWideChar( Value, PWideChar( P ), fBindings[ Idx ].cbMaxLen ); + Changed( Idx ); +end; + +procedure TQuery.SetText(const Value: String); +begin + // clear here current rowset if any: + ClearRowset; + {// set txt to fCommand -- do this at the last moment just before execute + CheckOLE( fCommand.SetCommandText( DBGUID_DBSQL, StringToOleStr( Value ) ) );} + FText := Value; +end; + +procedure TQuery.Update; +var Params, Results: array of DWORD; + I: Integer; +begin + if Mode <> rmUpdateDelayed then Exit; + if (fDelList <> nil) and (fDelList.Count > 0) then + begin + SetLength( Params, fDelList.Count ); + SetLength( Results, fDelList.Count ); + for I := 0 to fDelList.Count-1 do + Params[ I ] := DWORD( fDelList.Items[ I ] ); + CheckOLE( fRowSetUpd.DeleteRows( 0, fDelList.Count, @ Params[ 0 ], @ Results[ 0 ] ) ); + Free_And_Nil( fDelList ); + end; + if fRowSetUpd = nil then Exit; + CheckOLE( fRowSetUpd.Update( 0, 0, nil, nil, nil, nil ) ); +end; + +end. diff --git a/Addons/KOLFontEditor.pas b/Addons/KOLFontEditor.pas new file mode 100644 index 0000000..f284d6c --- /dev/null +++ b/Addons/KOLFontEditor.pas @@ -0,0 +1,424 @@ +unit KOLFontEditor; +{ +================================================================== + + TKOLFont Property Editor + for MCK + + ----------------------------------------------- + Version: 1.0 + Date: 16-sep-2003 + Author: (C) Alexander Pravdin (aka SPeller) + e-mail: speller@mail.primorye.ru + www: http://kol.mastak.ru + http://bonanzas.rinet.ru + + Thanks to: + Dmitry Zharov (aka Gandalf): + Start point of this component (MHFontDialog). + Delphi 5 and Delphi 7 support. + + Tested Delphi versions: 5, 6, 7. + +==================================================================} + +interface + +{$I KOLDEF.INC} + +uses KOL, Windows, Messages, Graphics, Forms, CommDlg, Mirror, +{$IFDEF _D6orHigher} + DesignEditors, DesignIntf; +{$ELSE} + DsgnIntf; +{$ENDIF} + +type + + TKOLFontProperty = class(TClassProperty) + private + DlgWnd, + hWndOwner, + LabelWnd, + PickWnd, + FontLWnd, + EditWnd, + CBWnd: HWND; + ColorDlg: PColorDialog; + Top, Left, Height, Width, + OldPickWndProc, + OldEditWndProc: Integer; + Colors: PList; + Font: TFont; + Color: Integer; + function DlgExecute: Boolean; + public + function GetAttributes: TPropertyAttributes; override; + procedure Edit; override; + end; + +procedure Register; + +implementation + +const + ID_DLGOBJ = 'ID_DLGOBJ'#0; + DLG_LBLID = 11200; + DLG_PICKID = 11201; + DLG_EDITID = 11202; + DLG_COLORCB = 1139; + DLG_EFFECTSGROUP = 1072; + + CN_APPLYCOLOR = 501; + +function PickWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall; +var + _Self : TKOLFontProperty; + R : TRect; + hBr, DC : THandle; +begin + _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ)); + with _Self do + begin + case Msg of + WM_PAINT: + begin + GetClientRect(Wnd, R); + CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam); + hBr := CreateSolidBrush(Color); + DC := GetDC(Wnd); + FillRect(DC, R, hBr); + ReleaseDC(Wnd, DC); + DeleteObject(hBr); + Result := 0; + Exit; + end; + end; // case + Result := CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam); + end; // with +end; + +function EditWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall; +var + _Self : TKOLFontProperty; +begin + _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ)); + with _Self do + begin + Result := CallWindowProc(Pointer(OldEditWndProc), Wnd, Msg, wParam, lParam); + end; // with +end; + +function FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall; +var + _Self : TKOLFontProperty; + R, R2, SR : TRect; + I, tmID, CBCurSel, CBCount: Integer; + PCF : PChooseFontA; + tmWnd, ChildWnd, hFont: THandle; + st : string; + FR : Boolean; +begin + Result := 0; + _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ)); + if (_Self = nil) and (Msg = WM_INITDIALOG) then + begin + PCF := Pointer(lParam); + SetProp(Wnd, ID_DLGOBJ, Cardinal(PCF.lCustData)); + _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ)); + end; + + with _Self do + begin + case Msg of + WM_INITDIALOG: + begin + DlgWnd := Wnd; + GetWindowRect(Wnd, R); + SR := MakeRect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)); + Width := R.Right - R.Left; + Height := R.Bottom - R.Top + 0; + Left := (SR.Left + SR.Right - Width) div 2; + Top := (SR.Top + SR.Bottom - Height) div 2; + SetWindowPos(Wnd, 0, Left, Top, Width, Height, SWP_NOZORDER); + + ChildWnd := 0; + repeat + ChildWnd := FindWindowEx(Wnd, ChildWnd, 'COMBOBOX', nil); + tmID := GetWindowLong(ChildWnd, GWL_ID); + until (tmID = DLG_COLORCB) or (ChildWnd = 0); + if ChildWnd <> 0 then + begin + CBWnd := ChildWnd; + GetWindowRect(CBWnd, R); + R.Right := R.Right + 5; + SetWindowPos(CBWnd, 0, 0, 0, R.Right - R.Left, R.Bottom - R.Top, SWP_NOZORDER or SWP_NOMOVE); + end else + Exit; + + ChildWnd := 0; + repeat + ChildWnd := FindWindowEx(Wnd, ChildWnd, 'BUTTON', nil); + tmID := GetWindowLong(ChildWnd, GWL_ID); + until (tmID = DLG_EFFECTSGROUP) or (ChildWnd = 0); + if ChildWnd <> 0 then + begin + tmWnd := ChildWnd; + GetWindowRect(tmWnd, R); + ScreenToClient(Wnd, R.TopLeft); + ScreenToClient(Wnd, R.BottomRight); + R.Bottom := R.Bottom + 20; + SetWindowPos(tmWnd, HWND_BOTTOM, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, 0); + end else + Exit; + + ChildWnd := 0; + repeat + ChildWnd := FindWindowEx(Wnd, ChildWnd, 'STATIC', nil); + tmID := GetWindowLong(ChildWnd, GWL_ID); + until (tmID = 1093) or (ChildWnd = 0); + if ChildWnd <> 0 then + begin + FontLWnd := ChildWnd; + GetWindowRect(FontLWnd, R2); + R2 := MakeRect(7, 172, 219, 20); + R2.Top := R2.Top + 25; + R2.Bottom := R2.Bottom + 20; + SetWindowPos(FontLWnd, 0, R2.Left, R2.Top, R2.Right - R2.Left, R2.Bottom - R2.Top, SWP_NOZORDER); + end; + + LabelWnd := CreateWindow('STATIC', 'Exactly:', + SS_LEFT or WS_VISIBLE or WS_CHILD, + R.Left + 10, R.Bottom - 26, 40, 15, + Wnd, 0, hInstance, nil); + SetWindowLong(LabelWnd, GWL_ID, DLG_LBLID); + SetProp(LabelWnd, ID_DLGOBJ, Cardinal(_Self)); + hFont := SendMessage(Wnd, WM_GETFONT, 0, 0); + SendMessage(LabelWnd, WM_SETFONT, hFont, 0); + + if WinVer >= wvXP then + begin + I := 0; + tmID := WS_BORDER; + end else + begin + I := WS_EX_CLIENTEDGE; + tmID := 0; + end; + PickWnd := CreateWindowEx(I, + 'STATIC', nil, + WS_VISIBLE or WS_CHILD or SS_NOTIFY or tmID, + R.Left + 116, R.Bottom - 30, 21, 21, + Wnd, 0, hInstance, nil); + SetProp(PickWnd, ID_DLGOBJ, Cardinal(_Self)); + SetWindowLong(PickWnd, GWL_ID, DLG_PICKID); + OldPickWndProc := SetWindowLong(PickWnd, GWL_WNDPROC, Integer(@PickWndProc)); + + EditWnd := CreateWindowEx(WS_EX_CLIENTEDGE, + 'EDIT', nil, + WS_VISIBLE or WS_CHILD or ES_UPPERCASE or ES_AUTOHSCROLL, + R.Left + 60, R.Bottom - 30, 55, 21, + Wnd, 0, hInstance, nil); + SetWindowLong(EditWnd, GWL_ID, DLG_EDITID); + SetProp(EditWnd, ID_DLGOBJ, Cardinal(_Self)); + SendMessage(EditWnd, WM_SETFONT, hFont, 0); + SendMessage(EditWnd, EM_SETLIMITTEXT, 6, 0); + OldEditWndProc := SetWindowLong(EditWnd, GWL_WNDPROC, Integer(@EditWndProc)); + + ColorDlg.OwnerWindow := Wnd; + + CBCount := SendMessage(CBWnd, CB_GETCOUNT, 0, 0); + for I := 0 to CBCount - 1 do + begin + Colors.Add(Pointer(SendMessage(CBWnd, CB_GETITEMDATA, I, 0))); + end; + CBCurSel := Colors.IndexOf(Pointer(Color)); + if CBCurSel < 0 then + begin + SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6)))); + Colors.Add(Pointer(Color)); + CBCurSel := Colors.Count - 1; + SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color); + end; + SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0); + TSmallPoint(I).x := DLG_COLORCB; + TSmallPoint(I).y := CBN_SELCHANGE; + SendMessage(Wnd, WM_COMMAND, I, CBWnd); + + end; + + WM_COMMAND: + begin + case TSmallPoint(wParam).X of + DLG_PICKID: + begin + case TSmallPoint(wParam).Y of + STN_CLICKED: + begin + if GetWindowLong(PickWnd, GWL_USERDATA) = CN_APPLYCOLOR then + FR := True + else + begin + ColorDlg.Color := Color; + FR := ColorDlg.Execute; + if FR then Color := ColorDlg.Color; + end; + if FR then + begin + //----- + CBCurSel := Colors.IndexOf(Pointer(Color)); + if CBCurSel < 0 then + begin + SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6)))); + Colors.Add(Pointer(Color)); + CBCurSel := Colors.Count - 1; + SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color); + end; + SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0); + TSmallPoint(I).Y := CBN_SELCHANGE; + TSmallPoint(I).X := DLG_COLORCB; + SendMessage(Wnd, WM_COMMAND, I, CBWnd); + //----- + end; + end; // STN_CLICKED + end; // case + end; // DLG_PICKID + + DLG_COLORCB: + begin + if TSmallPoint(wParam).Y = CBN_SELCHANGE then + begin + CBCurSel := SendMessage(CBWnd, CB_GETCURSEL, 0, 0); + if CBCurSel >= 0 then + begin + Color := SendMessage(CBWnd, CB_GETITEMDATA, CBCurSel, 0); + SetWindowText(EditWnd, PChar(Int2Hex(Color, 6))); + SendMessage(PickWnd, WM_PAINT, 0, 0); + end; + end; + end; // DLG_COLORCB + + DLG_EDITID: + begin + case TSmallPoint(wParam).Y of + EN_CHANGE: + begin + SetLength(st, 20); + GetWindowText(EditWnd, @st[1], 18); + Color := Hex2Int(st); + SendMessage(PickWnd, WM_PAINT, 0, 0); + end; + end; + end; // DLG_EDITID + + end; // case TSmallPoint( wParam ).X + end; // WM_COMMAND + + end; // case + end; // with +end; + +function TKOLFontProperty.DlgExecute: Boolean; +var + TMPCF : tagChooseFont; + TMPLogFont : tagLogFontA; +begin + FillChar(TMPCF, SizeOf(TMPCF), 0); + GetObject(Font.Handle, SizeOf(tagLOGFONT), @TMPLogFont); + + TMPCF.lStructSize := Sizeof(TMPCF); + TMPCF.hWndOwner := hWndOwner; + TMPCF.Flags := CF_EFFECTS or CF_BOTH or CF_ENABLEHOOK or CF_INITTOLOGFONTSTRUCT; + TMPCF.lpfnHook := FontDialogHook; + TMPCF.lpLogFont := @TMPLogFont; + TMPCF.rgbColors := Color2RGB(Font.Color); + TMPCF.lCustData := Integer(Self); + Color := TMPCF.rgbColors; + + Result := ChooseFont(TMPCF); + + if Result then + begin + DeleteObject(Font.Handle); + Font.Handle := CreateFontIndirect(TMPLogFont); + Font.Color := Color; + end; +end; + +function TKOLFontProperty.GetAttributes: TPropertyAttributes; +begin + Result := inherited GetAttributes + [paDialog, paReadOnly]; +end; + +procedure TKOLFontProperty.Edit; +const + Pitch2API : array[TFontPitch] of Byte = (DEFAULT_PITCH, VARIABLE_PITCH, FIXED_PITCH); +var + LF : tagLOGFONT; + F : TKOLFont; + FS1 : TFontStyles; +begin + //---------------- + hWndOwner := Application.Handle; + Font := TFont.Create; + Colors := NewList; + ColorDlg := NewColorDialog(ccoFullOpen); + //----------------- + F := TKOLFont(GetOrdValue); + + FillChar(LF, SizeOf(tagLOGFONT), 0); + LF.lfHeight := F.FontHeight; + LF.lfWidth := F.FontWidth; + LF.lfOrientation := F.FontOrientation; + if fsBold in F.FontStyle then LF.lfWeight := 700; + LF.lfItalic := Byte(fsItalic in F.FontStyle); + LF.lfUnderline := Byte(fsUnderline in F.FontStyle); + LF.lfStrikeOut := Byte(fsStrikeOut in F.FontStyle); + LF.lfCharSet := F.FontCharset; + LF.lfPitchAndFamily := Pitch2API[F.FontPitch]; + Move(F.FontName[1], LF.lfFaceName, Length(F.FontName)); + Font.Color := F.Color; + + Font.Handle := CreateFontIndirect(LF); + + if DlgExecute then + begin + FillChar(LF, SizeOf(tagLOGFONT), 0); + GetObject(Font.Handle, SizeOf(tagLOGFONT), @LF); + F.FontHeight := LF.lfHeight; + F.FontWidth := LF.lfWidth; + F.FontOrientation := LF.lfOrientation; + + FS1 := []; + if Boolean(LF.lfItalic) then Include(FS1, fsItalic); + if Boolean(LF.lfUnderline) then Include(FS1, fsUnderline); + if Boolean(LF.lfStrikeOut) then Include(FS1, fsStrikeout); + if LF.lfWeight > FW_NORMAL then Include(FS1, fsBold); + F.FontStyle := FS1; + + F.FontCharset := LF.lfCharSet; + case LF.lfPitchAndFamily of + DEFAULT_PITCH: F.FontPitch := fpDefault; + FIXED_PITCH: F.FontPitch := fpFixed; + VARIABLE_PITCH: F.FontPitch := fpVariable; + end; + F.FontName := LF.lfFaceName; + F.Color := Font.Color; + + SetOrdValue(Integer(F)); + end; + + //----------------- + ColorDlg.Free; + Colors.Free; + Font.Free; + //----------------- +end; + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLFont), nil, '', TKOLFontProperty); +end; + +end. + diff --git a/Addons/KOLGRushControls.pas b/Addons/KOLGRushControls.pas new file mode 100644 index 0000000..170a11a --- /dev/null +++ b/Addons/KOLGRushControls.pas @@ -0,0 +1,3307 @@ +unit KOLGRushControls; +{* +|GRushControls - Controls set with high quality of visulation and effects. +| +|
  file: KOLGRushControls.pas +|
  file version: 0.36 +|
  last modified: 17.10.07 +|
  author: Karpinskyj Alexandr aka homm +|
    mailto: +|homm86@mail.ru +|
     My humble Web-Page: +|www.homm86.narod.ru +|

Symbols of conditionally compilation.

+Most common rule: All symbols by default are switched on. They are located on top of unit +KOLGRushControls.pas directly after this description. +Undefination of one of them makes code smaller and unsafely or less functionality. +|

MOSTCOMPATIBILITY
+Switch this define on to get most functionality code versilon. +All folowing defination are ingoring. +|

ALLOW_GLYPH
+Allows use Glyphs. +|

ALLOW_ANTIALIASING
+Allows you use antialiasing. +|

ALLOW_CONTROLSTRANSPARANSY
+Force right processing Transparent property. +|

FIX_16BITMODE
+Fixes not glide gradient in Windows 2000/XP. +|

FIX_DRAWTRANSPARENT
+Use TransparentBlt instead of TBitmap.DrawTransparent in Windows 2000/XP. +Incrase performance. +|

NOT_IMMIDIATLYONLY
+Allow use fading controls changing. +|

USE_MMX
+Allow use MMX for controls fading. Incrase performance a bit. +(Matters only with previos defination) +} +{= +|GRushControls + - Элементы управления с высоким качества отображения и визуальных эффектов +| +|
  файл: KOLGRushControls.pas +|
  версия файла: 0.36 +|
  последнее изменение: 17.10.07 +|
  автор: Карпинский Александр aka homm +|
    mailto: +|homm86@mail.ru +|
    моя скромная интернет страница: +|http://www.homm86.narod.ru +|

Символы условной компиляции

+Общее правило: по умолчанию все символы определены. Они находятся в начале файла +KOLGRushControls.pas сразу за этим описанием. Убирание любого из них уменьшает код, +и в зависимости от конкретного символа уменьшает функциональность или добовляет глюков. +|

MOSTCOMPATIBILITY
+Включить для получения наиболее функциональной версии. Все остальные символы +определяются автоматически. +|

ALLOW_GLYPH
+Позволяет использовать картинки на контролах. +|

ALLOW_ANTIALIASING
+Позволяет сглаживать края бордюра. +|

ALLOW_CONTROLSTRANSPARANSY
+Заставляет контролы правильно понимать свойство Transparent. +|

FIX_16BITMODE
+Исправляет не плвный градиент в 16 битах палитры для Windows 2000/XP. +|

FIX_DRAWTRANSPARENT
+Использует TransparentBlt вместо TBitmap.DrawTransparent в Windows 2000/XP. +Увеличивает производительность. +|

NOT_IMMIDIATLYONLY
+Включает плавное перетикание контролов при изменении состояния. +|

USE_MMX
+Использует MMX для альфа-смешивания. Слегка увеличивает проиводительность. +(Имеет значение только если предидушее условие определено) +} + + + + +{$DEFINE MOSTCOMPATIBILITY} +{$DEFINE ALLOW_GLYPH} +{$DEFINE ALLOW_ANTIALIASING} +{$DEFINE ALLOW_CONTROLSTRANSPARANSY} +{$DEFINE FIX_16BITMODE} +{$DEFINE FIX_DRAWTRANSPARENT} +{$DEFINE NOT_IMMIDIATLYONLY} +{$DEFINE USE_MEMSAVEMODE} +{//$DEFINE USE_2XAA_INSTEAD_OF_4XAA} +{$DEFINE USE_MMX} + + + + + + + + + + + + + + + + + +interface + +uses Windows, + Messages, + KOL; + +{$I KOLDEF.inc} + +{$IFDEF MOSTCOMPATIBILITY} + {$DEFINE ALLOW_GLYPH} + {$DEFINE ALLOW_ANTIALIASING} + {$DEFINE ALLOW_CONTROLSTRANSPARANSY} + {$DEFINE FIX_16BITMODE} + {$DEFINE FIX_DRAWTRANSPARENT} + {$DEFINE NOT_IMMIDIATLYONLY} + {$DEFINE USE_MMX} + {$DEFINE USE_MEMSAVEMODE} + {$DEFINE USE_2XAA_INSTEAD_OF_4XAA} +{$ENDIF MOSTCOMPATIBILITY} + +{$IFNDEF NOT_IMMIDIATLYONLY} + {$IFDEF USE_MMXTOO} + {$UNDEF USE_MMXTOO} + {$ENDIF USE_MMXTOO} +{$ENDIF NOT_IMMIDIATLYONLY} + +{$IFDEF FIX_DRAWTRANSPARENT} + {$DEFINE SYSNEED} +{$ENDIF FIX_DRAWTRANSPARENT} + +{$IFDEF FIX_16BITMODE} + {$DEFINE SYSNEED} +{$ENDIF FIX_16BITMODE} + +{$UNDEF PCode} + +{$IFDEF _D2005orHigher} + {$ALIGN 1} +{$ENDIF} + + +type + PGRushControl = ^TGRushControl; + //PGRushStyleMamanger = ^TGRushStyleMamanger; + PGRushData = ^TGRushData; + + TKOLGRushButton = PGRushControl; + TKOLGRushPanel = PGRushControl; + TKOLGRushCheckBox = PGRushControl; + TKOLGRushRadioBox = PGRushControl; + TKOLGRushSplitter = PGRushControl; + TKOLGRushProgressBar = PGRushControl; + TKOLGRushImageCollection = PBitmap; + + + TGRushOrientation = (orHorizontal, orVertical); + TGRushGradientStyle = (gsSolid, gsVertical, gsHorizontal, gsDoubleVert + , gsDoubleHorz, gsFromTopLeft, gsFromTopRight); + TGRushState = set of (gsOver, gsDown); + TGRushStateInit = (siNone, siKey, siButton); + TGRushCurrentOperation = (coDefToOver, coDefToDown, coOverToDef + , coOverToDown, coDownToDef, coDownToOver); + TGRushToUpdate = set of (tuDef, tuOver, tuDown, tuDis); + TGRushControlType = (_ct00, _ct01, _ct02, _ct03, _ct04, _ct05, _ct06, _ct07, _ct08, _ct09, _ct0a, _ct0b, _ct0c, _ct0d, _ct0e, _ct0f + , _ct10, _ct11, _ct12, _ct13, _ct14, _ct15, _ct16, _ct17, _ct18, _ct19, _ct1a, _ct1b, _ct1c, _ct1d, _ct1e, _ct1f + , ctButton { $20}, ctPanel { $21}, ctCheckBox { $22} + , ctRadioBox { $23}, ctSplitter { $24}, ctProgressBar { $25}); + TGRushSpeed = (usImmediately, usVeryFast, usFast, usNormal, usSlow, usVerySlow); + // 64(1) 13(5) 10(7) 8(8) 6(11) 4(16) + TGRushHAlign = (haLeft, haCenter, haRight); + + TGRushPaintState = packed record + {+} ColorFrom: TColor; + {+} ColorTo: TColor; + { } ColorOuter: TColor; + {+} ColorText: TColor; +//16 + {+} ColorShadow: TColor; + {+} BorderColor: TColor; + { } BorderRoundWidth: DWORD; + { } BorderRoundHeight: DWORD; +//32 + {+} BorderWidth: DWORD; + {+} GradientStyle: TGRushGradientStyle; + {+} ShadowOffset: Integer; + { } GlyphItemX: DWORD; + { } GlyphItemY: DWORD; +//44 + end; + + TGrushRects = packed record + DefBorderRect: TRect; + OverBorderRect: TRect; + DownBorderRect: TRect; + DisBorderRect: TRect; + AlphaRect: TRect; + end; + + TOnRecalcRects = procedure( Sender: PGRushControl; var Rects: TGRushRects ) of object; + TOnGRushControl = procedure( Sender: PGRushControl) of object; + TOnProgressChange = TOnGRushControl; + + TGRushData = {$IFNDEF _D2005orHigher} packed {$ENDIF} object(TObj) + fSplDotsOrient: TGRushOrientation; + + fPSDef: TGRushPaintState; + fPSOver: TGRushPaintState; + fPSDown: TGRushPaintState; + fPSDis: TGRushPaintState; +//176 + fContentOffsets: TRect; + fGlyphWidth: DWORD; + fGlyphHeight: DWORD; + fSplitterDotsCount: DWORD; + fCheckMetric: DWORD; + fColorCheck: TColor; +//208 + fGlyphVAlign: TVerticalAlign; + fGlyphHAlign: TGRushHAlign; + fTextVAlign: TVerticalAlign; + fTextHAlign: TGRushHAlign; + {?}fDrawGlyph: Boolean; + {?}fDrawText: Boolean; + {?}fDrawFocusRect: Boolean; + {?}fDrawProgress: Boolean; + {?}fDrawProgressRect: Boolean; + {?}fGlyphAttached: Boolean; + {?}fCropTopFirst: Boolean; + {?}fAntiAliasing: Boolean; + {?}fProgressVertical: Boolean; + fUpdateSpeed: TGRushSpeed; + fSpacing: DWORD; +//224 +//83 + fProgress: DWORD; + fProgressRange: DWORD; + fNeedDib: Boolean; + + fDefNeedUpdate: Boolean; + fOverNeedUpdate: Boolean; + fDownNeedUpdate: Boolean; + fDisNeedUpdate: Boolean; + fResultNeedUpdate: Boolean; + + fControlType: TGRushControlType; + fOnRecalcRects: TOnRecalcRects; + fOnProgressChange: TOnGRushControl; + fGlyphBitmap: PBitmap; + fRects: TGRushRects; + fBlendPercent: Integer; + fState: TGRushState; + fActive: Boolean; + fStateInit: TGRushStateInit; + fCurrentOperation: TGRushCurrentOperation; + + fDefPatern: PBitmap; + fOverPatern: PBitmap; + fDownPatern: PBitmap; + fDisPatern: PBitmap; + fResultPatern: PBitmap; + public + destructor Destroy; virtual; + end; + + TGRushFake = packed record + fPSDef: TGRushPaintState; + fPSOver: TGRushPaintState; + fPSDown: TGRushPaintState; + fPSDis: TGRushPaintState; +//176 + fContentOffsets: TRect; + fGlyphWidth: DWORD; + fGlyphHeight: DWORD; + fSplitterDotsCount: DWORD; + fCheckMetric: DWORD; + fColorCheck: TColor; +//208 + fGlyphVAlign: TVerticalAlign; + fGlyphHAlign: TGRushHAlign; + fTextVAlign: TVerticalAlign; + fTextHAlign: TGRushHAlign; + fDrawGlyph: Boolean; + fDrawText: Boolean; + fDrawFocusRect: Boolean; + fDrawProgress: Boolean; + fDrawProgressRect: Boolean; + fGlyphAttached: Boolean; + fCropTopFirst: Boolean; + fAntiAliasing: Boolean; + fProgressVertical: Boolean; + fUpdateSpeed: TGRushSpeed; + fSpacing: DWORD; +//224 + fProgress: DWORD; + fProgressRange: DWORD; + fNeedDib: Boolean; + + fDefNeedUpdate: Boolean; + fOverNeedUpdate: Boolean; + fDownNeedUpdate: Boolean; + fDisNeedUpdate: Boolean; + fResultNeedUpdate: Boolean; + end; + +{ + TGRushStyleManager = object (TObj) + private + fCtlList: TList; + public + procedure RegisterControl (AControl: PGRushControl); + procedure UnRegisterControl(AControl: PGRushControl); + //procedure UpdateStyle; + end; +} + + TGRushControl = object (TControl) + {* This Object implements all functionality of GRush Controls. All added properties named by followinf rule: + If property takes effect on one of the four state, its name begining with following prefixes: + |Def_, Over_, Down_, Dis_. + if property provide common functionality, its name begining with prefix + |All_. Also all state-effect propertes can be changed with write-only property, named as + | state-effect propertes, but with prefix All_ } + + {= Объект, инкапсулирующий всю фунциональность GRush контролов. Все добавленые свойства именованы + по следующим правилам: Если свойство оказывает влияние только на одно из четырех базовых состояний, его + |имя начинается с следующих префиксов (по ожному на состояние): Def_, Over_, Down_, Dis_. + Если свойство обеспечивает обшую функциональность, то его имя начинается с префикса + |All_. Так же все свойства состояний имеют метод для записи, изменяя который изменяются + |все свойства состояния. Он также начинается с префикса All_.} + protected + function GetAll_SplDotsOrient: TGRushOrientation; + procedure SetAll_SplDotsOrient(const Value: TGRushOrientation); + function GetDef_ColorFrom: integer; procedure SetDef_ColorFrom(Val: integer); + function GetDef_ColorTo: integer; procedure SetDef_ColorTo(Val: integer); + function GetDef_ColorOuter: integer; procedure SetDef_ColorOuter(Val: integer); + function GetDef_ColorText: integer; procedure SetDef_ColorText(Val: integer); + function GetDef_ColorShadow: integer; procedure SetDef_ColorShadow(Val: integer); + function GetDef_BorderColor: integer; procedure SetDef_BorderColor(Val: integer); + function GetDef_BorderWidth: DWORD; procedure SetDef_BorderWidth(Val: DWORD); + function GetDef_BorderRoundWidth: DWORD; procedure SetDef_BorderRoundWidth(Val: DWORD); + function GetDef_BorderRoundHeight: DWORD; procedure SetDef_BorderRoundHeight(Val: DWORD); + function GetDef_ShadowOffset: Integer; procedure SetDef_ShadowOffset(Val: Integer); + function GetDef_GradientStyle: TGRushGradientStyle; procedure SetDef_GradientStyle(Val: TGRushGradientStyle); + function GetDef_GlyphItemX: DWORD; procedure SetDef_GlyphItemX(Val: DWORD); + function GetDef_GlyphItemY: DWORD; procedure SetDef_GlyphItemY(Val: DWORD); + + function GetOver_ColorFrom: integer; procedure SetOver_ColorFrom(Val: integer); + function GetOver_ColorTo: integer; procedure SetOver_ColorTo(Val: integer); + function GetOver_ColorOuter: integer; procedure SetOver_ColorOuter(Val: integer); + function GetOver_ColorText: integer; procedure SetOver_ColorText(Val: integer); + function GetOver_ColorShadow: integer; procedure SetOver_ColorShadow(Val: integer); + function GetOver_BorderColor: integer; procedure SetOver_BorderColor(Val: integer); + function GetOver_BorderWidth: DWORD; procedure SetOver_BorderWidth(Val: DWORD); + function GetOver_BorderRoundWidth: DWORD; procedure SetOver_BorderRoundWidth(Val: DWORD); + function GetOver_BorderRoundHeight: DWORD; procedure SetOver_BorderRoundHeight(Val: DWORD); + function GetOver_ShadowOffset: Integer; procedure SetOver_ShadowOffset(Val: Integer); + function GetOver_GradientStyle: TGRushGradientStyle; procedure SetOver_GradientStyle(Val: TGRushGradientStyle); + function GetOver_GlyphItemX: DWORD; procedure SetOver_GlyphItemX(Val: DWORD); + function GetOver_GlyphItemY: DWORD; procedure SetOver_GlyphItemY(Val: DWORD); + + function GetDown_ColorFrom: integer; procedure SetDown_ColorFrom(Val: integer); + function GetDown_ColorTo: integer; procedure SetDown_ColorTo(Val: integer); + function GetDown_ColorOuter: integer; procedure SetDown_ColorOuter(Val: integer); + function GetDown_ColorText: integer; procedure SetDown_ColorText(Val: integer); + function GetDown_ColorShadow: integer; procedure SetDown_ColorShadow(Val: integer); + function GetDown_BorderColor: integer; procedure SetDown_BorderColor(Val: integer); + function GetDown_BorderWidth: DWORD; procedure SetDown_BorderWidth(Val: DWORD); + function GetDown_BorderRoundWidth: DWORD; procedure SetDown_BorderRoundWidth(Val: DWORD); + function GetDown_BorderRoundHeight: DWORD; procedure SetDown_BorderRoundHeight(Val: DWORD); + function GetDown_ShadowOffset: Integer; procedure SetDown_ShadowOffset(Val: Integer); + function GetDown_GradientStyle: TGRushGradientStyle; procedure SetDown_GradientStyle(Val: TGRushGradientStyle); + function GetDown_GlyphItemX: DWORD; procedure SetDown_GlyphItemX(Val: DWORD); + function GetDown_GlyphItemY: DWORD; procedure SetDown_GlyphItemY(Val: DWORD); + + function GetDis_ColorFrom: integer; procedure SetDis_ColorFrom(Val: integer); + function GetDis_ColorTo: integer; procedure SetDis_ColorTo(Val: integer); + function GetDis_ColorOuter: integer; procedure SetDis_ColorOuter(Val: integer); + function GetDis_ColorText: integer; procedure SetDis_ColorText(Val: integer); + function GetDis_ColorShadow: integer; procedure SetDis_ColorShadow(Val: integer); + function GetDis_BorderColor: integer; procedure SetDis_BorderColor(Val: integer); + function GetDis_BorderWidth: DWORD; procedure SetDis_BorderWidth(Val: DWORD); + function GetDis_BorderRoundWidth: DWORD; procedure SetDis_BorderRoundWidth(Val: DWORD); + function GetDis_BorderRoundHeight: DWORD; procedure SetDis_BorderRoundHeight(Val: DWORD); + function GetDis_ShadowOffset: Integer; procedure SetDis_ShadowOffset(Val: Integer); + function GetDis_GradientStyle: TGRushGradientStyle; procedure SetDis_GradientStyle(Val: TGRushGradientStyle); + function GetDis_GlyphItemX: DWORD; procedure SetDis_GlyphItemX(Val: DWORD); + function GetDis_GlyphItemY: DWORD; procedure SetDis_GlyphItemY(Val: DWORD); + + function GetAll_CheckMetric: DWORD; procedure SetAll_CheckMetric(Val: DWORD); + function GetAll_GlyphVAlign: TVerticalAlign; procedure SetAll_GlyphVAlign(Val: TVerticalAlign); + function GetAll_GlyphHAlign: TGRushHAlign; procedure SetAll_GlyphHAlign(Val: TGRushHAlign); + function GetAll_TextVAlign: TVerticalAlign; procedure SetAll_TextVAlign(Val: TVerticalAlign); + function GetAll_TextHAlign: TGRushHAlign; procedure SetAll_TextHAlign(Val: TGRushHAlign); + function GetAll_DrawText: Boolean; procedure SetAll_DrawText(Val: Boolean); + function GetAll_DrawGlyph: Boolean; procedure SetAll_DrawGlyph(Val: Boolean); + function GetAll_DrawFocusRect: Boolean; procedure SetAll_DrawFocusRect(Val: Boolean); + function GetAll_DrawProgress: Boolean; procedure SetAll_DrawProgress(Val: Boolean); + function GetAll_DrawProgressRect: Boolean; procedure SetAll_DrawProgressRect(Val: Boolean); + function GetAll_ProgressVertical: Boolean; procedure SetAll_ProgressVertical(Val: Boolean); + function GetAll_GlyphBitmap: PBitmap; procedure SetAll_GlyphBitmap(Val: PBitmap); + function GetAll_ContentOffsets: TRect; procedure SetAll_ContentOffsets(const Val: TRect); + function GetAll_AntiAliasing: Boolean; procedure SetAll_AntiAliasing(Val: boolean); + function GetAll_UpdateSpeed: TGRushSpeed; procedure SetAll_UpdateSpeed(Val: TGRushSpeed); + function GetAll_ColorCheck: TColor; procedure SetAll_ColorCheck(Val: TColor); + function GetAll_GlyphWidth: DWORD; procedure SetAll_GlyphWidth(Val: DWORD); + function GetAll_GlyphHeight: DWORD; procedure SetAll_GlyphHeight(Val: DWORD); + function GetAll_Spacing: DWORD; procedure SetAll_Spacing(Val: DWORD); + function GetAll_SplitterDotsCount: DWORD; procedure SetAll_SplitterDotsCount(Val: DWORD); + function GetAll_CropTopFirst: Boolean; procedure SetAll_CropTopFirst(Val: Boolean); + function GetAll_GlyphAttached: Boolean; procedure SetAll_GlyphAttached(Val: Boolean); + + procedure SetAll_ColorFrom(Val: integer); + procedure SetAll_ColorTo(Val: integer); + procedure SetAll_ColorOuter(Val: integer); + procedure SetAll_ColorText(Val: integer); + procedure SetAll_ColorShadow(Val: integer); + procedure SetAll_BorderColor(Val: integer); + procedure SetAll_BorderWidth(Val: DWORD); + procedure SetAll_BorderRoundWidth(Val: DWORD); + procedure SetAll_BorderRoundHeight(Val: DWORD); + procedure SetAll_ShadowOffset(Val: Integer); + procedure SetAll_GradientStyle(Val: TGRushGradientStyle); + procedure SetAll_GlyphItemX(Val: DWORD); + procedure SetAll_GlyphItemY(Val: DWORD); + + function GetOnRecalcRects: TOnRecalcRects; procedure SetOnRecalcRects (const val: TOnRecalcRects); + function GetOnProgressChange: TOnGRushControl; procedure SetOnProgressChange (const val: TOnGRushControl); + + procedure DoEnter (Sender: PObj); + procedure DoExit (Sender: PObj); + procedure DoPush; + procedure DoPop; + procedure DoPaint (Ctl_: PControl; DC: HDC); + procedure DeActivateSublings; + procedure InitLast(MEnterExit: Boolean; CT: TGRushControlType); + procedure UpdateProgress; + procedure TimerEvent(Data: PGRushData); + procedure DrawControlState(var Bitmap: PBitmap; const BorderRect: TRect; + const State: TGRushPaintState; UseDIB: boolean); + procedure CleanMem(Data: PGRushData); + public +//-------- + property Def_ColorFrom: integer + read GetDef_ColorFrom write SetDef_ColorFrom; + {* Sets the first color, used in gradient fill} + {= Первый цвет, используемый для градиента} + property Def_ColorTo: Integer + read GetDef_ColorTo write SetDef_ColorTo; + {* Sets the second color, used in gradient fill} + {= Второй цвет, используемый для градиента} + property Def_ColorOuter: Integer + read GetDef_ColorOuter write SetDef_ColorOuter; + {* Sets color, used to fill part of control, which not fills with gradient} + {= Цвет, используемый для заполнения той части контрола, где нет градиента} + property Def_ColorText: integer + read GetDef_ColorText write SetDef_ColorText; + {* Sets color, used to draw text on control} + {= Цвет для рисования текста.} + property Def_ColorShadow: Integer + read GetDef_ColorShadow write SetDef_ColorShadow; + {* Sets color, used to draw text shadow on control} + {= Цвет для рисования тени текста} + property Def_BorderColor: Integer + read GetDef_BorderColor write SetDef_BorderColor; + {* Sets color, used to draw border of control} + {= Цвет для рисования бордюра} + property Def_BorderWidth: DWORD + read GetDef_BorderWidth write SetDef_BorderWidth; + {* Width of line, used to draw border} + {= Ширина линии бордюра контрола} + property Def_BorderRoundWidth: DWORD + read GetDef_BorderRoundWidth write SetDef_BorderRoundWidth; + {* Width of arc, drawed instead of border corner. If is 0, no arc drawed} + {= Ширина дуги, рисуемой вместо углов бордюра. Если 0, углы острые} + property Def_BorderRoundHeight: DWORD + read GetDef_BorderRoundHeight write SetDef_BorderRoundHeight; + {* Height of arc, drawed instead of border corner. If is 0, no arc drawed} + {= Высота дуги, рисуемой вместо углов бордюра. Если 0, углы острые} + property Def_ShadowOffset: Integer + read GetDef_ShadowOffset write SetDef_ShadowOffset; + {* Offset of text shadow. Positiv value means offset to the bottom and right. If is 0, no shadow drawed} + {= Смещение тени текста. Положительное значение - смещение вниз и вправо. Если 0, тень не рисуется} + property Def_GradientStyle: TGRushGradientStyle + read GetDef_GradientStyle write SetDef_GradientStyle; + {* Style of gradient fill. One of following values: + | gsSolid, gsVertical, gsHorizontal, gsDoubleVert, gsDoubleHorz, gsFromTopLeft, gsFromTopRight} + {= Стиль градиента. Одно из следующих значений: + | gsSolid, gsVertical, gsHorizontal, gsDoubleVert, gsDoubleHorz, gsFromTopLeft, gsFromTopRight} + property Def_GlyphItemX: DWORD + read GetDef_GlyphItemX write SetDef_GlyphItemX; + {* X coordinate of Glyph, cuted from All_GlyphBitmap. See All_GlyphWidth, All_GlyphHeight} + {= Координата Х рисунка, вырезаемого из All_GlyphBitmap. См. All_GlyphWidth, All_GlyphHeight} + property Def_GlyphItemY: DWORD + read GetDef_GlyphItemY write SetDef_GlyphItemY; + {* Y coordinate of Glyph, cuted from All_GlyphBitmap. See All_GlyphWidth, All_GlyphHeight} + {= Координата Y рисунка, вырезаемого из All_GlyphBitmap. См. All_GlyphWidth, All_GlyphHeight} +//-------- + property Over_ColorFrom: integer + read GetOver_ColorFrom write SetOver_ColorFrom; + property Over_ColorTo: integer + read GetOver_ColorTo write SetOver_ColorTo; + property Over_ColorOuter: integer + read GetOver_ColorOuter write SetOver_ColorOuter; + property Over_ColorText: integer + read GetOver_ColorText write SetOver_ColorText; + property Over_ColorShadow: integer + read GetOver_ColorShadow write SetOver_ColorShadow; + property Over_BorderColor: integer + read GetOver_BorderColor write SetOver_BorderColor; + property Over_BorderWidth: DWORD + read GetOver_BorderWidth write SetOver_BorderWidth; + property Over_BorderRoundWidth: DWORD + read GetOver_BorderRoundWidth write SetOver_BorderRoundWidth; + property Over_BorderRoundHeight: DWORD + read GetOver_BorderRoundHeight write SetOver_BorderRoundHeight; + property Over_ShadowOffset: Integer + read GetOver_ShadowOffset write SetOver_ShadowOffset; + property Over_GradientStyle: TGRushGradientStyle + read GetOver_GradientStyle write SetOver_GradientStyle; + property Over_GlyphItemX: DWORD + read GetOver_GlyphItemX write SetOver_GlyphItemX; + property Over_GlyphItemY: DWORD + read GetOver_GlyphItemY write SetOver_GlyphItemY; +//-------- + property Down_ColorFrom: integer + read GetDown_ColorFrom write SetDown_ColorFrom; + property Down_ColorTo: integer + read GetDown_ColorTo write SetDown_ColorTo; + property Down_ColorOuter: integer + read GetDown_ColorOuter write SetDown_ColorOuter; + property Down_ColorText: integer + read GetDown_ColorText write SetDown_ColorText; + property Down_ColorShadow: integer + read GetDown_ColorShadow write SetDown_ColorShadow; + property Down_BorderColor: integer + read GetDown_BorderColor write SetDown_BorderColor; + property Down_BorderWidth: DWORD + read GetDown_BorderWidth write SetDown_BorderWidth; + property Down_BorderRoundWidth: DWORD + read GetDown_BorderRoundWidth write SetDown_BorderRoundWidth; + property Down_BorderRoundHeight: DWORD + read GetDown_BorderRoundHeight write SetDown_BorderRoundHeight; + property Down_ShadowOffset: Integer + read GetDown_ShadowOffset write SetDown_ShadowOffset; + property Down_GradientStyle: TGRushGradientStyle + read GetDown_GradientStyle write SetDown_GradientStyle; + property Down_GlyphItemX: DWORD + read GetDown_GlyphItemX write SetDown_GlyphItemX; + property Down_GlyphItemY: DWORD + read GetDown_GlyphItemY write SetDown_GlyphItemY; +//-------- + property Dis_ColorFrom: integer + read GetDis_ColorFrom write SetDis_ColorFrom; + property Dis_ColorTo: integer + read GetDis_ColorTo write SetDis_ColorTo; + property Dis_ColorOuter: integer + read GetDis_ColorOuter write SetDis_ColorOuter; + property Dis_ColorText: integer + read GetDis_ColorText write SetDis_ColorText; + property Dis_ColorShadow: integer + read GetDis_ColorShadow write SetDis_ColorShadow; + property Dis_BorderColor: integer + read GetDis_BorderColor write SetDis_BorderColor; + property Dis_BorderWidth: DWORD + read GetDis_BorderWidth write SetDis_BorderWidth; + property Dis_BorderRoundWidth: DWORD + read GetDis_BorderRoundWidth write SetDis_BorderRoundWidth; + property Dis_BorderRoundHeight: DWORD + read GetDis_BorderRoundHeight write SetDis_BorderRoundHeight; + property Dis_ShadowOffset: Integer + read GetDis_ShadowOffset write SetDis_ShadowOffset; + property Dis_GradientStyle: TGRushGradientStyle + read GetDis_GradientStyle write SetDis_GradientStyle; + property Dis_GlyphItemX: DWORD + read GetDis_GlyphItemX write SetDis_GlyphItemX; + property Dis_GlyphItemY: DWORD + read GetDis_GlyphItemY write SetDis_GlyphItemY; +//-------- + property All_ContentOffsets: TRect + read GetAll_ContentOffsets write SetAll_ContentOffsets; + {* } + {= } + property All_CheckMetric: DWORD + read GetAll_CheckMetric write SetAll_CheckMetric; + {* } + {= } + property All_GlyphHAlign: TGRushHAlign + read GetAll_GlyphHAlign write SetAll_GlyphHAlign; + {* } + {= } + property All_GlyphVAlign: TVerticalAlign + read GetAll_GlyphVAlign write SetAll_GlyphVAlign; + {* } + {= } + property All_TextHAlign: TGRushHAlign + read GetAll_TextHAlign write SetAll_TextHAlign; + {* } + {= } + property All_TextVAlign: TVerticalAlign + read GetAll_TextVAlign write SetAll_TextVAlign; + {* } + {= } + property All_DrawText: Boolean + read GetAll_DrawText write SetAll_DrawText; + {* } + {= } + property All_DrawGlyph: Boolean + read GetAll_DrawGlyph write SetAll_DrawGlyph; + {* } + {= } + property All_DrawFocusRect: Boolean + read GetAll_DrawFocusRect write SetAll_DrawFocusRect; + {* } + {= } + property All_DrawProgress: Boolean + read GetAll_DrawProgress write SetAll_DrawProgress; + {* } + {= } + property All_DrawProgressRect: Boolean + read GetAll_DrawProgressRect write SetAll_DrawProgressRect; + {* } + {= } + property All_ProgressVertical: Boolean + read GetAll_ProgressVertical write SetAll_ProgressVertical; + {* } + {= } + property All_UpdateSpeed: TGRushSpeed + read GetAll_UpdateSpeed write SetAll_UpdateSpeed; + {* } + {= } + property All_ColorCheck: TColor + read GetAll_ColorCheck write SetAll_ColorCheck; + {* } + {= } + property All_GlyphWidth: DWORD + read GetAll_GlyphWidth write SetAll_GlyphWidth; + {* } + {= } + property All_GlyphHeight: DWORD + read GetAll_GlyphHeight write SetAll_GlyphHeight; + {* } + {= } + property All_GlyphBitmap: PBitmap + read GetAll_GlyphBitmap write SetAll_GlyphBitmap; + {* } + {= } + property All_AntiAliasing: Boolean + read GetAll_AntiAliasing write SetAll_AntiAliasing; + {* } + {= } + property All_Spacing: DWORD + read GetAll_Spacing write SetAll_Spacing; + {* } + {= } + property All_SplitterDotsCount: DWORD + read GetAll_SplitterDotsCount write SetAll_SplitterDotsCount; + {* } + {= } + property All_SplDotsOrient: TGRushOrientation + read GetAll_SplDotsOrient write SetAll_SplDotsOrient; + {* } + {= } + property All_CropTopFirst: Boolean + read GetAll_CropTopFirst write SetAll_CropTopFirst; + {* } + {= } + property All_GlyphAttached: Boolean + read GetAll_GlyphAttached write SetAll_GlyphAttached; + {* } + {= } + property All_ColorFrom: Integer + write SetAll_ColorFrom; + property All_ColorTo: Integer + write SetAll_ColorTo; + property All_ColorOuter: Integer + write SetAll_ColorOuter; + property All_ColorText: Integer + write SetAll_ColorText; + property All_ColorShadow: Integer + write SetAll_ColorShadow; + property All_BorderColor: integer + write SetAll_BorderColor; + property All_BorderWidth: DWORD + write SetAll_BorderWidth; + property All_BorderRoundWidth: DWORD + write SetAll_BorderRoundWidth; + property All_BorderRoundHeight: DWORD + write SetAll_BorderRoundHeight; + property All_ShadowOffset: Integer + write SetAll_ShadowOffset; + property All_GradientStyle: TGRushGradientStyle + write SetAll_GradientStyle; + property All_GlyphItemX: DWORD + write SetAll_GlyphItemX; + property All_GlyphItemY: DWORD + write SetAll_GlyphItemY; + + property OnRecalcRects: TOnRecalcRects + read GetOnRecalcRects write SetOnRecalcRects; + property OnProgressChange: TOnGRushControl + read GetOnProgressChange write SetOnProgressChange; + + procedure SetAllNeedUpdate; + procedure CheckNeedUpdate (ToUpdate: TGRushToUpdate; UseDIBs: Boolean); + procedure VoidRecalcRect(Sender: PGRushControl; var Rects: TGRushRects ); + end; + + function NewGRushButton(AParent: PControl; Caption: String):PGRushControl; + function NewGRushPanel(AParent: PControl):PGRushControl; + function NewGRushCheckBox(AParent: PControl; Caption: String):PGRushControl; + function NewGRushRadioBox(AParent: PControl; Caption: String):PGRushControl; + function NewGRushSplitter(AParent: PControl; MinSizePrev, MinSizeNext: Integer):PGRushControl; + function NewGRushProgressBar(AParent: PControl):PGRushControl; + + function AlignColorTo16Bit(Color: TColor):TColor; + function Max4 (A, B, C, D: Integer):Integer; + function Min4 (A, B, C, D: Integer):Integer; + procedure BitmapAntialias4X(SrcBitmap, DstBitmap: PBitmap); // With MMX support !!! + procedure BitmapAntialias2X(SrcBitmap, DstBitmap: PBitmap); // With MMX support !!! + procedure BlendBitmaps(var DestBitmap, FromBitmap, ToBitmap: PBitmap; Factor: Integer; ClipRect:TRect); // With MMX support !!! + procedure GradientFill(const State: TGRushPaintState; DC: HDC; const BorderRect: TRect); + +const + CheckContentRect: TRect = (Left: 19; Top: 1; Right: -1; Bottom: -1); + ProgressBarContentRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); + DefGRushData: TGRushFake = ( + fPSDef: ( + ColorFrom: clWhite; + ColorTo: $D1beaf; + ColorOuter: clBtnFace; + ColorText: clBlack; + ColorShadow: clWhite; + BorderColor: clMedGray; + BorderRoundWidth: 4; + BorderRoundHeight: 4; + BorderWidth: 1; + GradientStyle: gsVertical; + ShadowOffset: 1; + GlyphItemX: 0; + GlyphItemY: 0; + ); + fPSOver: ( + ColorFrom: $e1cebf; + ColorTo: clWhite; + ColorOuter: clBtnFace; + ColorText: clBlack; + ColorShadow: clGray; + BorderColor: clMedGray; + BorderRoundWidth: 4; + BorderRoundHeight: 4; + BorderWidth: 1; + GradientStyle: gsDoubleVert; + ShadowOffset: 1; + GlyphItemX: 0; + GlyphItemY: 0; + ); + fPSDown: ( + ColorFrom: clCream; + ColorTo: $b6bFc6; + ColorOuter: clBtnFace; + ColorText: clBlack; + ColorShadow: clGray; + BorderColor: clGray; + BorderRoundWidth: 8; + BorderRoundHeight: 4; + BorderWidth: 2; + GradientStyle: gsDoubleHorz; + ShadowOffset: -1; + GlyphItemX: 0; + GlyphItemY: 0; + ); + fPSDis: ( + ColorFrom: clWhite; + ColorTo: $9EACB4; + ColorOuter: clBtnFace; + ColorText: clBlack; + ColorShadow: clGray; + BorderColor: clGray; + BorderRoundWidth: 5; + BorderRoundHeight: 5; + BorderWidth: 2; + GradientStyle: gsFromTopLeft; + ShadowOffset: 2; + GlyphItemX: 0; + GlyphItemY: 0; + ); + fContentOffsets: (Left: 4; + Top: 4; + Right: -4; + Bottom: -4); + fGlyphWidth: 0; + fGlyphHeight: 0; + fSplitterDotsCount: 0; + fCheckMetric: 13; + fColorCheck: $F3706C; + fGlyphVAlign: vaCenter; + fGlyphHAlign: haLeft; + fTextVAlign: vaCenter; + fTextHAlign: haCenter; + fDrawGlyph: TRUE; + fDrawText: TRUE; + fDrawFocusRect: TRUE; + fDrawProgress: FALSE; + fDrawProgressRect: FALSE; + fGlyphAttached: FALSE; + fCropTopFirst: TRUE; + fAntiAliasing: TRUE; + fProgressVertical: FALSE; + //gsImmediately usVeryFast usFast usNormal usSlow usVerySlow + fUpdateSpeed: usFast; + fSpacing: 5; + + fProgress: 0; + fProgressRange: 100; + fNeedDib: TRUE; + fDefNeedUpdate: TRUE; + fOverNeedUpdate: TRUE; + fDownNeedUpdate: TRUE; + fDisNeedUpdate: TRUE; + fResultNeedUpdate: TRUE; + ); + +implementation + +type + TRIVERTEX = packed record + X, Y : DWORD; + Red, Green, Blue, Alpha : Word; + end; + TA = array [0..129] of byte; + +var CheckRgn, + RadioRgn: HRGN; + {$IFDEF USE_MMX} + UseMMX: boolean; + {$ENDIF USE_MMX} + {$IFDEF SYSNEED} + UseSystemGradient: boolean; + hinst_msimg32: HInst; + SysGradientFill: function(DC: hDC; pVertex: Pointer; dwNumVertex: DWORD; + pMesh: Pointer; dwNumMesh, dwMode: DWORD): Bool; stdcall; + {$IFDEF FIX_DRAWTRANSPARENT} + SysTransparentBlt: function(DC: HDC; p2, p3, p4, p5: Integer; DC6: HDC; + p7, p8, p9, p10: Integer; p11: UINT): BOOL; stdcall; + {$ENDIF FIX_DRAWTRANSPARENT} + {$ENDIF SYSNEED} + +const + ID_GRUSHTYPE : {$IFDEF UNICODE_CTRLS} + array[0..10] of WideChar = ( 'G','R','U','S','H','_','T','Y','P','E',#0 ) + {$ELSE} + array[0..10] of Char = ( 'G','R','U','S','H','_','T','Y','P','E',#0 ) + {$ENDIF}; + AlphaIncrement : array [TGRushSpeed] of integer = (64, 22, 13, 8, 6, 4); + //GT_BUTTON : DWORD = $000020; + //GT_PANEL : DWORD = $000021; + //GT_CHECKBOX : DWORD = $000022; + GT_RADIOBOX : DWORD = $000023; + msimg32 = 'msimg32.dll'; + _Check: TA = (1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, + 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, + 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 1, + 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1); + _Radio: TA = (1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + +function RegionFromArray(_A: TA):HRGN; +var _TempRgn: HRGN; + i, j: integer; +begin + Result := CreateRectRgn(0, 0, 0, 0); + For j := 0 to 9 do + for i := 3 to 15 do + if _A[(j*13)+i-3] = 0 then begin + _TempRgn := CreateRectRgn(i, j, i+1, j+1); + CombineRGN(Result, Result, _TempRgn, RGN_OR); + DeleteObject(_TempRgn); + end; +end; + +function CPUisMMX: Boolean; +var I: Integer; +begin + I := 0; + Result := false; + asm // check if bit 21 of EFLAGS can be set and reset + PUSHFD + POP EAX + OR EAX, 1 shl 21 + PUSH EAX + POPFD + PUSHFD + POP EAX + TEST EAX, 1 shl 21 + JZ @@1 + AND EAX, not( 1 shl 21 ) + PUSH EAX + POPFD + PUSHFD + POP EAX + TEST EAX, 1 shl 21 + JNZ @@1 + INC [ I ] + @@1: + end; + if I = 0 then Exit; // CPUID not supported + asm // get CPU features flags using CPUID command + MOV EAX, 1 + PUSH EDX + PUSH EBX + PUSH ECX + DB $0F, $A2 + MOV [ I ], EDX // I := features information + POP ECX + POP EBX + POP EDX + end; + if (I and (1 shl 23)) <> 0 then + Result := true; +end; + +(* +function Data2Hex(Data: Pointer; Count: integer): Pointer; + function HexDigit( B : Byte ) : Char; + {$IFDEF F_P} + const + HexDigitChr: array[ 0..15 ] of Char = ( '0','1','2','3','4','5','6','7', + '8','9','A','B','C','D','E','F' ); + begin + Result := HexDigitChr[ B and $F ]; + end; + {$ELSE DELPHI} + asm + DB $3C,9 + JA @@1 + DB $04, $30-$41+$0A + @@1: + DB $04, $41-$0A + end; + {$ENDIF F_P/DELPHI} + +var i: integer; + ch: byte; +begin + GetMem(Result, Count*2); + for i := 0 to Count-1 do begin + ch := Byte(PChar(Data)[i]); + PChar(Result)[i*2] := HexDigit( ch and $F ); + ch := ch shr 4; + PChar(Result)[i*2+1] := HexDigit( ch and $F ); + end; +end; *) + +function AlignColorTo16Bit; +begin + Color := Color2RGB( Color ); + Result := ((((Color shr 19) and $1f) * 541052) and $FF0000) or + (((((Color shr 10) and $3F) * 266294) shr 8) and $FF00) or + ((((Color shr 3) and $1f) * 541052) shr 16); +end; + +procedure AlignRect(var Result: TRect; const Container: TRect; VA: TVerticalAlign; HA: TGRushHAlign); +var Wi, He: integer; +begin + Wi := Result.Right - Result.Left; + He := Result.Bottom - Result.Top; + case HA of + haLeft: + begin + Result.Left := Container.Left; + Result.Right := Result.Left + Wi; + end; + haCenter: + begin + Result.Left := (Container.Right + Container.Left - Wi) div 2; + Result.Right := Result.Left + Wi; + end; + haRight: + begin + Result.Right := Container.Right; + Result.Left := Result.Right - Wi; + end; + end; + case VA of + vaTop: + begin + Result.Top := Container.Top; + Result.Bottom := Result.Top + He; + end; + vaCenter: + begin + Result.Top := (Container.Bottom + Container.Top - He) div 2; + Result.Bottom := Result.Top + He; + end; + vaBottom: + begin + Result.Bottom := Container.Bottom; + Result.Top := Result.Bottom - He; + end; + end; +end; + +function Max4 (A, B, C, D: Integer):Integer; +begin + if (A > B) and (A > C) and (A > D) then + result := A + else + if (B > C) and (B > D) then + result := B + else + if (C > D) then + Result := C + else + Result := D; + if Result < 0 then + Result := 0; +end; + +function Min4 (A, B, C, D: Integer):Integer; +begin + if (A < B) and (A < C) and (A < D) then + result := A + else + if (B < C) and (B < D) then + result := B + else + if (C < D) then + Result := C + else + Result := D; + if Result > 0 then + Result := 0; +end; + +function AddRects(const R1: TRect; const R2: TRect): TRect; +begin + with Result do begin + Left := R1.Left + R2.Left; + Top := R1.Top + R2.Top; + Right := R1.Right + R2.Right; + Bottom := R1.Bottom + R2.Bottom; + end; +end; + +procedure ClickGRushRadio( Sender:PObj ); +begin + PGRushControl( Sender ).fChecked := TRUE; +end; + +{$IFDEF FIX_DRAWTRANSPARENT} +procedure myDrawTransparent(Bitmap: PBitmap; DC: HDC; X: Integer; Y: Integer; Color: TColor); +var bW, bH: integer; +begin + bW := Bitmap.Width; + bH := Bitmap.Height; + Color := Color2RGB(Color); + if UseSystemGradient then + SysTransparentBlt(DC, X, Y, bW, bH, Bitmap.Canvas.Handle, 0, 0, bW, bH, Color) + else + Bitmap.DrawTransparent(DC, X, Y, Color); +end; +{$ENDIF FIX_DRAWTRANSPARENT} + +{procedure TGRushStyleManager.RegisterControl (AControl: PGRushControl); +begin + if fCtlList.IndexOf(AControl) < 0 then + fCtlList.Add(AControl); +end; + +procedure TGRushStyleManager.UnRegisterControl (AControl: PGRushControl); +var IndOF: integer; +begin + IndOF := fCtlList.IndexOf(AControl); + if (IndOF >= 0) then + fCtlList.Delete(IndOF); +end;} + +procedure BitmapAntialias4X(SrcBitmap, DstBitmap: PBitmap); +type AGRBQuad = array [0..0] of TRGBQuad; + PAGRBQuad = ^AGRBQuad; +var yDest: integer; + xDest: integer; + xSrc: integer; + i: integer; + R: integer; + G: integer; + B: integer; + rowDest: PAGRBQuad; + rowSrc: array [0..3] of PAGRBQuad; + _rowSrc: PAGRBQuad; + {$IFDEF USE_MMX} + SrcBits: DWORD; + DstBits: DWORD; + dHeight: DWORD; + dWidth: DWORD; + Delta: DWORD; + {$ENDIF USE_MMX} +begin + {$IFDEF USE_MMX} + if UseMMX then begin + SrcBits := DWORD(SrcBitmap.DIBBits); + DstBits := DWORD(DstBitmap.DIBBits); + dHeight := DstBitmap.Height; + dWidth := DstBitmap.Width; + Delta := SrcBitmap.ScanLineSize; + asm + pushad + mov esi, SrcBits + mov edi, DstBits + //pxor mm2, mm2 + db $0f, $ef, $d2 + + mov eax, dHeight +@LM1: push eax + + mov eax, dWidth +@LM2: ///////// + mov ecx, esi + + //movd mm1, [ecx] + db $0f, $6e, $09 + //punpcklbw mm1, mm2 + db $0f, $60, $ca + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+8] + db $0f, $6e, $59, $08 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+12] + db $0f, $6e, $59, $0c + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + add ecx, Delta + + //movd mm3, [ecx] + db $0f, $6e, $19 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+8] + db $0f, $6e, $59, $08 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+12] + db $0f, $6e, $59, $0c + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + add ecx, Delta + + //movd mm3, [ecx] + db $0f, $6e, $19 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+8] + db $0f, $6e, $59, $08 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+12] + db $0f, $6e, $59, $0c + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + add ecx, Delta + + //movd mm3, [ecx] + db $0f, $6e, $19 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+8] + db $0f, $6e, $59, $08 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+12] + db $0f, $6e, $59, $0c + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + //psrlw mm1, 4 + db $0f, $71, $d1, $04 + //packuswb mm1, mm2 + db $0f, $67, $ca + //movd [edi], mm1 + db $0f, $7e, $0f + ///////// + add edi, 4 + add esi, 16 + + sub eax, 1 + jnz @LM2 + + mov ecx, Delta + lea esi, [esi + ecx*2] + add esi, ecx + + pop eax + sub eax, 1 + jnz @LM1 + + //emms + db $0f, $77 + + popad + end; + end else + {$ENDIF USE_MMX} + for yDest := 0 to DstBitmap.Height -1 do begin + rowDest := DstBitmap.ScanLine[yDest]; + for i := 0 to 3 do + rowSrc[i] := SrcBitmap.ScanLine[yDest*4+i]; + for xDest := 0 to DstBitmap.Width-1 do begin + xSrc := xDest*4; + R:=0; G:=0; B:=0; + for i := 0 to 3 do begin + _rowSrc := rowSrc[i]; + R:= R+_rowSrc[xSrc+0].rgbRed + + _rowSrc[xSrc+1].rgbRed + + _rowSrc[xSrc+2].rgbRed + + _rowSrc[xSrc+3].rgbRed; + G:= G+_rowSrc[xSrc+0].rgbGreen + + _rowSrc[xSrc+1].rgbGreen + + _rowSrc[xSrc+2].rgbGreen + + _rowSrc[xSrc+3].rgbGreen; + B:= B+_rowSrc[xSrc+0].rgbBlue + + _rowSrc[xSrc+1].rgbBlue + + _rowSrc[xSrc+2].rgbBlue + + _rowSrc[xSrc+3].rgbBlue; + end; + DWORD(rowDest[xDest]) := ((R and $0ff0) shl 12) or ((G and $0ff0) shl 4) or (B shr 4); + end; + end; +end; + +procedure BitmapAntialias2X(SrcBitmap, DstBitmap: PBitmap); +type AGRBQuad = array [0..0] of TRGBQuad; + PAGRBQuad = ^AGRBQuad; +var yDest: integer; + xDest: integer; + xSrc: integer; + i: integer; + R: integer; + G: integer; + B: integer; + rowDest: PAGRBQuad; + rowSrc: array [0..3] of PAGRBQuad; + _rowSrc: PAGRBQuad; + {$IFDEF USE_MMX} + SrcBits: DWORD; + DstBits: DWORD; + dHeight: DWORD; + dWidth: DWORD; + Delta: DWORD; + {$ENDIF USE_MMX} +begin + {$IFDEF USE_MMX} + if UseMMX then begin + SrcBits := DWORD(SrcBitmap.DIBBits); + DstBits := DWORD(DstBitmap.DIBBits); + dHeight := DstBitmap.Height; + dWidth := DstBitmap.Width; + Delta := SrcBitmap.ScanLineSize; + asm + pushad + mov esi, SrcBits + mov edi, DstBits + //pxor mm2, mm2 + db $0f, $ef, $d2 + + mov eax, dHeight +@LM1: push eax + + mov eax, dWidth +@LM2: ///////// + mov ecx, esi + + //movd mm1, [ecx] + db $0f, $6e, $09 + //punpcklbw mm1, mm2 + db $0f, $60, $ca + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + add ecx, Delta + + //movd mm3, [ecx] + db $0f, $6e, $19 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + //movd mm3, [ecx+4] + db $0f, $6e, $59, $04 + //punpcklbw mm3, mm2 + db $0f, $60, $da + //paddusw mm1, mm3 + db $0f, $dd, $cb + + //psrlw mm1, 2 + db $0f, $71, $d1, $02 + //packuswb mm1, mm2 + db $0f, $67, $ca + //movd [edi], mm1 + db $0f, $7e, $0f + ///////// + + add edi, 4 + add esi, 8 + + sub eax, 1 + jnz @LM2 + + add esi, Delta + + pop eax + sub eax, 1 + jnz @LM1 + + //emms + db $0f, $77 + + popad + end; + end else + {$ENDIF USE_MMX} + for yDest := 0 to DstBitmap.Height -1 do begin + rowDest := DstBitmap.ScanLine[yDest]; + for i := 0 to 1 do + rowSrc[i] := SrcBitmap.ScanLine[yDest*2+i]; + for xDest := 0 to DstBitmap.Width-1 do begin + xSrc := xDest*2; + R:=0; G:=0; B:=0; + for i := 0 to 1 do begin + _rowSrc := rowSrc[i]; + R:= R+_rowSrc[xSrc+0].rgbRed + + _rowSrc[xSrc+1].rgbRed; + G:= G+_rowSrc[xSrc+0].rgbGreen + + _rowSrc[xSrc+1].rgbGreen; + B:= B+_rowSrc[xSrc+0].rgbBlue + + _rowSrc[xSrc+1].rgbBlue; + end; + DWORD(rowDest[xDest]) := ((R and $03fc) shl 14) or ((G and $03fc) shl 6) or (B shr 2); + end; + end; +end; + +procedure BlendBitmaps(var DestBitmap, FromBitmap, ToBitmap: PBitmap; Factor: Integer; ClipRect:TRect); +type AGRBQuad = array [0..0] of TRGBQuad; + PAGRBQuad = ^AGRBQuad; +var Factor2: byte; + i, j: integer; + DestRow: PAGRBQuad; + FromRow: PAGRBQuad; + ToRow: PAGRBQuad; + {$IFDEF USE_MMX} + FromDibBits: DWORD; + ToDibBits: DWORD; + DestDibBits: DWORD; + _Width: integer; + _Height: integer; + _Right: integer; + _Top: DWORD; + {$ENDIF USE_MMX} +begin + {$IFDEF USE_MMX} + if UseMMX then begin + _Top := FromBitmap.Width * 4 * ClipRect.Top + ClipRect.Left * 4; + FromDibBits := DWORD(FromBitmap.DIBBits) + _Top; + ToDibBits := DWORD(ToBitmap.DIBBits) + _Top; + DestDibBits := DWORD(DestBitmap.DIBBits) + _Top; + _Width := ClipRect.Right - ClipRect.Left; + _Height := ClipRect.Bottom - ClipRect.Top; + _Right := (FromBitmap.Width - ClipRect.Right + ClipRect.Left) * 4; + asm + mov edx, Factor + mov dh, dl + mov ax, dx + shl eax, 16 + mov ax, dx + + mov esi, FromDibBits + mov edi, ToDibBits + mov edx, DestDibBits + + //pxor mm2, mm2 + db $0f, $ef, $d2 + //movd mm3, eax + db $0f, $6e, $d8 + //punpcklbw mm3, mm2 + db $0f, $60, $da + + mov eax, $00404040 + //movd mm4, eax + db $0f, $6e, $e0 + //punpcklbw mm4, mm2 + db $0f, $60, $e2 + //psubw mm4, mm3 + db $0f, $f9, $e3 + + mov ecx, _Height +@LM1: + mov ebx, _Width +@LM2: + //movd mm0, [esi] + db $0f, $6e, $06 + //movd mm1, [edi] + db $0f, $6e, $0f + //punpcklbw mm0, mm2 + db $0f, $60, $c2 + //punpcklbw mm1, mm2 + db $0f, $60, $ca + //pmullw mm0, mm4 + db $0f, $d5, $c4 + //pmullw mm1, mm3 + db $0f, $d5, $cb + //paddusw mm1, mm0 + db $0f, $dd, $c8 + //psrlw mm1, 6 + db $0f, $71, $d1, $06 + //packuswb mm1, mm2 + db $0f, $67, $ca + //movd [edx], mm1 + db $0f, $7e, $0a + + add esi, 4 + add edi, 4 + add edx, 4 + + sub ebx, 1 + jnz @LM2 + + add esi, _Right + add edi, _Right + add edx, _Right + + sub ecx, 1 + jnz @LM1 + //emms + db $0f, $77 + end + end else + {$ENDIF USE_MMX} + begin + Factor2 := 64-Factor; + for i := ClipRect.Top to ClipRect.Bottom-1 do begin + DestRow := DestBitmap.ScanLine[i]; + FromRow := FromBitmap.ScanLine[i]; + ToRow := ToBitmap.ScanLine[i]; + for j := ClipRect.Left to (ClipRect.Right-1) do begin + DestRow[j].rgbBlue := ((FromRow[j].rgbBlue*Factor2) + (ToRow[j].rgbBlue*Factor)) shr 6; + DestRow[j].rgbGreen := ((FromRow[j].rgbGreen*Factor2) + (ToRow[j].rgbGreen*Factor)) shr 6; + DestRow[j].rgbRed := ((FromRow[j].rgbRed*Factor2) + (ToRow[j].rgbRed*Factor)) shr 6; + end; + end; + end; +end; + +destructor TGRushData.Destroy; +begin + if fGlyphBitmap <> nil then + fGlyphBitmap.RefDec; + //Free_And_Nil(fGlyphBitmap); //?????????? + Free_And_Nil(fDefPatern); + Free_And_Nil(fOverPatern); + Free_And_Nil(fDownPatern); + Free_And_Nil(fDisPatern); + Free_And_Nil(fResultPatern); + inherited; +end; + +procedure GradientFill(const State: TGRushPaintState; DC: HDC; const BorderRect: TRect); + type TGradientRect = packed record + UpperLeft: ULONG; + LowerRight: ULONG; + end; + const PatternSize = 32; + FromSize = 6; + GRADIENT_FILL_RECT_H = $00000000; + GRADIENT_FILL_RECT_V = $00000001; + var TR, ATR: TRect; + {$IFDEF FIX_16BITMODE} + vert: Array[0..3] of TRIVERTEX; + gTRi: TGradientRect; + Align: Integer; + tDC: HDC; + {$ENDIF FIX_16BITMODE} + C1, C2: TRGBQuad; + R1, R2, B1, B2, G1, G2: integer; + RectW, RectH: integer; + W, H, DW, DH, WH: integer; + Pattern: PBitmap; + i, C: integer; + Br: HBrush; + begin + RectH := BorderRect.Bottom - BorderRect.Top; + RectW := BorderRect.Right - BorderRect.Left; + if (RectH<=0) or (RectW<=0) then + exit; + + C1 := TRGBQuad(Color2RGB(State.ColorFrom)); + C2 := TRGBQuad(Color2RGB(State.ColorTo)); + R1 := C1.rgbRed; + R2 := C2.rgbRed; + G1 := C1.rgbGreen; + G2 := C2.rgbGreen; + B1 := C1.rgbBlue; + B2 := C2.rgbBlue; + {$IFDEF FIX_16BITMODE} + vert[0].x := 0; + vert[0].y := 0; + vert[0].Red := B1 shl 8; + vert[0].Green := G1 shl 8; + vert[0].Blue := R1 shl 8; + vert[0].Alpha := $00; + vert[1].Red := B2 shl 8; + vert[1].Green := G2 shl 8; + vert[1].Blue := R2 shl 8; + vert[1].Alpha := $00; + vert[2] := vert[0]; + vert[2].x := RectW; + vert[2].y := 0; + gTRi.UpperLeft := 0; + gTRi.LowerRight := 1; + {$ENDIF FIX_16BITMODE} + R2 := R2 - R1; + G2 := G2 - G1; + B2 := B2 - B1; + DW := 0; + DH := 0; + + case State.GradientStyle of + gsHorizontal: + begin + W := RectW; + H := PatternSize; + WH := W; + end; + gsVertical: + begin + W := PatternSize; + H := RectH; + WH := H; + end; + gsDoubleHorz: + begin + DW := RectW; + W := DW shr 1; + H := PatternSize; + DH := H; + WH := W; + end; + gsDoubleVert: + begin + W := PatternSize; + DH := RectH; + H := DH shr 1; + DW := W; + WH := H; + {$IFDEF FIX_16BITMODE} + vert[2].x := 0; + vert[2].y := RectH; + {$ENDIF FIX_16BITMODE} + end; + gsFromTopLeft, + gsFromTopRight: + begin + W := RectH + RectW; + H := 1 + (RectH div 32); + if H > 6 then + H := 6; + WH := W; + end; + else exit; + end; + + if not (State.GradientStyle in [gsDoubleVert, gsDoubleHorz]) then begin + DW := W; + DH := H; + end; + Pattern := NewBitMap(DW, DH); + {$IFDEF FIX_16BITMODE} + vert[1].x := W; + vert[1].y := H; + + if State.GradientStyle in [gsVertical, gsDoubleVert] then + align := GRADIENT_FILL_RECT_V + else + align := GRADIENT_FILL_RECT_H; + + if UseSystemGradient then begin //UseSystemGradient + tDC := Pattern.Canvas.Handle; + if State.GradientStyle in [gsDoubleHorz, gsDoubleVert] then + sysGradientFill(tDC, @(vert[1]), 2, @gTRI, 1, align); + sysGradientFill(tDC, @vert, 2, @gTRI, 1, align); + end else begin //UseSystemGradient + {$ENDIF FIX_16BITMODE} + case State.GradientStyle of + gsVertical, gsDoubleVert: + begin + TR := MakeRect(0, 0, DW, 1); + DW := 0; + DH := 1; + end; + gsHorizontal, gsFromTopLeft, gsFromTopRight, gsDoubleHorz: + begin + TR := MakeRect(0, 0, 1, DH); + DW := 1; + DH := 0; + end; + end; + if State.GradientStyle = gsDoubleVert then + ATR := MakeRect(0, RectH-1, PatternSize, RectH); + if State.GradientStyle = gsDoubleHorz then + ATR := MakeRect(RectW-1, 0, RectW, PatternSize); + for i := 0 to WH do begin + C := ((( R1 + R2 * I div WH ) and $FF) shl 16) or + ((( G1 + G2 * I div WH ) and $FF) shl 8) or + ( B1 + B2 * I div WH ) and $FF; + Br := CreateSolidBrush( C ); + Windows.FillRect(Pattern.Canvas.Handle, TR, Br ); + + if State.GradientStyle in [gsDoubleHorz, gsDoubleVert] then + Windows.FillRect(Pattern.Canvas.Handle, ATR, Br); + OffsetRect(ATR, -DW, -DH); + OffsetRect(TR, DW, DH); + DeleteObject( Br ); + end; + {$IFDEF FIX_16BITMODE} + end; //UseSystemGradient + {$ENDIF FIX_16BITMODE} + + case State.GradientStyle of + gsHorizontal, gsDoubleHorz: + for i := 0 to (BorderRect.Bottom div PatternSize) do + Pattern.Draw(DC, BorderRect.Left, BorderRect.Top + i*PatternSize); + gsVertical, gsDoubleVert: + for i := 0 to (BorderRect.Right div PatternSize) do + Pattern.Draw(DC, BorderRect.Left + i*PatternSize, BorderRect.Top); + gsFromTopLeft: + for i := 0 to ((BorderRect.Bottom + H -1) div H)-1 do + Pattern.Draw(DC, BorderRect.Left + -i*H, BorderRect.Top + i*H); + gsFromTopRight: + for i := 0 to ((BorderRect.Bottom + H -1) div H)-1 do + Pattern.Draw(DC, BorderRect.Left - BorderRect.Bottom + i*H, BorderRect.Top + i*H); + end; + Pattern.Free; + end; + +procedure TGRushControl.DrawControlState(var Bitmap: PBitmap; const BorderRect: TRect; const State: TGRushPaintState; UseDIB: boolean); + + procedure NewElipseFSAA(const State: TGRushPaintState; const BorderRect: TRect; {$IFDEF ALLOW_ANTIALIASING}AA: Boolean;{$ENDIF} aBRW:Integer; aBRH: Integer); + {$IFDEF USE_2XAA_INSTEAD_OF_4XAA} + const Factor = 2; + {$ELSE USE_2XAA_INSTEAD_OF_4XAA} + const Factor = 4; + {$ENDIF USE_2XAA_INSTEAD_OF_4XAA} + var Wi, He: integer; + {$IFDEF ALLOW_ANTIALIASING} + TempBMP: PBitmap; + {$ENDIF ALLOW_ANTIALIASING} + DestDC: HDC; + SrcDC: HDC; + Rgn1: HRgn; + Rgn2: HRgn; + ElipseFSAA: PBitmap; + begin + with State do begin + {$IFDEF ALLOW_ANTIALIASING} + if AA then begin + Wi := aBRW * Factor; + He := aBRH * Factor; + ElipseFSAA := NewDIBBitmap(Wi*2, He*2, pf32bit); + end else {$ENDIF ALLOW_ANTIALIASING} begin + Wi := aBRW; + He := aBRH; + ElipseFSAA := NewBitmap(Wi*2, He*2); + end; + + {$IFDEF ALLOW_ANTIALIASING} + ElipseFSAA.Canvas.Pen.PenWidth := BorderWidth * ((byte(AA)*(Factor-1))+1); + {$ELSE ALLOW_ANTIALIASING} + ElipseFSAA.Canvas.Pen.PenWidth := BorderWidth; + {$ENDIF ALLOW_ANTIALIASING} + DestDC := ElipseFSAA.Canvas.Handle; + SrcDC := Bitmap.Canvas.Handle; + StretchBlt(DestDC, 0, 0, Wi, He, SrcDC, BorderRect.Left, BorderRect.Top, aBRW + , aBRH, SRCCOPY); + StretchBlt(DestDC, Wi, 0, Wi, He, SrcDC, BorderRect.Right-aBRW, BorderRect.Top + , aBRW, aBRH, SRCCOPY); + StretchBlt(DestDC, 0, He, Wi, He, SrcDC, BorderRect.Left, BorderRect.Bottom-aBRH + , aBRW, aBRH, SRCCOPY); + StretchBlt(DestDC, Wi, He, Wi, He, SrcDC, BorderRect.Right-aBRW + , BorderRect.Bottom-aBRH, aBRW, aBRH, SRCCOPY); + + with ElipseFSAA.Canvas^, Pen^ do begin + Rgn1 := CreateEllipticRgn(0, 0, Wi*2+1, He*2+1); + Rgn2 := CreateRectRgn(0, 0, Wi*2, He*2); + CombineRgn(Rgn1, Rgn1, Rgn2, RGN_XOR); + Brush.Color := ColorOuter; + FillRgn(Rgn1); + Brush.BrushStyle := bsClear; + DeleteObject(Rgn1); + DeleteObject(Rgn2); + + if BorderWidth > 0 then begin + GeometricPen := true; + PenStyle := psInsideFrame; + Color := BorderColor; + Ellipse(-1, -1, Wi*2, He*2); + end; + //ElipseFsAA.Draw(Bitmap.Canvas.Handle, 0, 0); // + end; + {$IFDEF ALLOW_ANTIALIASING} + if AA then begin + TempBmp := NewDIBBitmap(aBRW*2, aBRH*2, pf32bit); + TempBmp.Handle; + {$IFDEF USE_2XAA_INSTEAD_OF_4XAA} + BitmapAntialias2X(ElipseFSAA, TempBMP); + {$ELSE USE_2XAA_INSTEAD_OF_4XAA} + BitmapAntialias4X(ElipseFSAA, TempBMP); + {$ENDIF USE_2XAA_INSTEAD_OF_4XAA} + ElipseFsAA.Free; + ElipseFsAA := TempBmp; + end; + {$ENDIF ALLOW_ANTIALIASING} + DestDC := ElipseFSAA.Canvas.Handle; + BitBlt(SrcDC, BorderRect.Left, BorderRect.Top + , aBRW, aBRH, DestDC, 0, 0, SRCCOPY); + BitBlt(SrcDC, BorderRect.Right-aBRW, BorderRect.Top + , aBRW, aBRH, DestDC, aBRW, 0, SRCCOPY); + BitBlt(SrcDC, BorderRect.Left, BorderRect.Bottom-aBRH + , aBRW, aBRH, DestDC, 0, aBRH, SRCCOPY); + BitBlt(SrcDC, BorderRect.Right-aBRW, BorderRect.Bottom-aBRH + , aBRW, aBRH, DestDC, aBRW, aBRH, SRCCOPY); + + end; + ElipseFsAA.Free; + end; + + function Atom1(par1: integer; par2: integer; par3: integer): integer; + begin + result := ((par1-5*par3) div 2) + par2*5; + end; + + procedure MaxMin4( Data: PGRushData; var M: Integer; var N: Integer); + begin + M := Max(Data.fPSDef.ShadowOffset, Data.fPSOver.ShadowOffset); + M := Max(M, Data.fPSDown.ShadowOffset); + M := Max(M, Data.fPSDis.ShadowOffset); + N := Min(Data.fPSDef.ShadowOffset, Data.fPSOver.ShadowOffset); + N := Min(N, Data.fPSDown.ShadowOffset); + N := Min(N, Data.fPSDis.ShadowOffset); + if M < 0 then + M := 0; + if N > 0 then + N := 0; + end; + +var W, H: Integer; + TextClipRect: TRect; + _TextRect: TRect; + {$IFDEF ALLOW_GLYPH} + GlyphH, GlyphW: DWORD; + GlyphRect: TRect; + aDrawGlyph: Boolean; + R1, R2: TRect; + {$ENDIF ALLOW_GLYPH} + ContentRect: TRect; + Data: PGRushData; + aDrawText: Boolean; + M, N, i: integer; + _ti: integer; + Flags: integer; + aBRW, aBRH: Integer; + Cpt: String; + TBM: PBitmap; + +//const Spacing = 0; +begin + W := Width; + H := Height; + if (W<=0) or (H<=0) then + exit; + if not (Bitmap = nil) then + Bitmap.Free; + {$IFDEF FIX_16BITMODE} + if WinVer <= wvNT then + Bitmap := NewDibBitMap(W, H, pf32bit) + else + {$ENDIF FIX_16BITMODE} + if UseDIB then + Bitmap := NewDIBBitMap(W, H, pf32bit) + else + Bitmap := NewBitMap(W, H); + + + with Bitmap.Canvas^, BorderRect, State do begin + M := Right - Left; + N := Bottom - Top; + if integer(BorderRoundWidth)*2 > M then + aBRW := (M+1) shr 1 + else + aBRW := BorderRoundWidth; + if integer(BorderRoundHeight)*2 > N then + aBRH := (N+1) shr 1 + else + aBRH := BorderRoundHeight; + + if (State.ColorFrom = State.ColorTo) or (State.GradientStyle = gsSolid) then begin + Brush.Color := State.ColorFrom; + FillRect(BorderRect); + end else begin + GradientFill(State, Handle, BorderRect); + end; + + Pen.Color := BorderColor; + Brush.Color := BorderColor; + Rectangle(Left+aBRW, Top, Right-aBRW, DWORD(Top)+BorderWidth); + Rectangle(Left+aBRW, Bottom-Integer(BorderWidth), Right-aBRW, Bottom); + Rectangle(Left, Top+aBRH, DWORD(Left)+BorderWidth, Bottom-aBRH); + Rectangle(Right-Integer(BorderWidth), Top+aBRH, Right, Bottom-aBRH); + + Pen.Color := ColorOuter; + Brush.Color := ColorOuter; + + Rectangle(0, 0, Left, Bottom); + Rectangle(Left, 0, W, Top); + Rectangle(Right, Top, W, H); + Rectangle(0, Bottom, Right, H); + end; + + Data := PGRushData(CustomObj); + if (aBRW>0) and (aBRH>0) and (M>0) and (N>0) then + NewElipseFSAA(State, BorderRect, {$IFDEF ALLOW_ANTIALIASING}Data.fAntiAliasing,{$ENDIF} aBRW, aBRH); + + ContentRect := AddRects(ClientRect, Data.fContentOffsets); + TextClipRect := ContentRect; + {$IFDEF ALLOW_GLYPH} + aDrawGlyph := (Data.fDrawGlyph) and (Data.fGlyphBitmap <> nil) and (not Data.fGlyphBitmap.Empty) + and (Data.fGlyphWidth <= DWORD(TextClipRect.Right - TextClipRect.Left)) + and (Data.fGlyphHeight <= DWORD(TextClipRect.Bottom - TextClipRect.Top)) + and (Data.fGlyphWidth > 0) and (Data.fGlyphHeight > 0); + aDrawText := Data.fDrawText and ((Caption <> '') or (Data.fDrawProgress)); + //aDrawText := (Data.fDrawText) and (Ctl_.Text <> ''); + {aDrawGlyph := (GlyphW <= (TextClipRect.Right - TextClipRect.Left)) // + and (GlyphH <= (TextClipRect.Bottom - TextClipRect.Top)); // } + + //Bitmap.Canvas.DrawFocusRect(TextClipRect); // + if aDrawGlyph then begin + GlyphH := Data.fGlyphHeight + Data.fSpacing; + GlyphW := Data.fGlyphWidth + Data.fSpacing; + if Data.fCropTopFirst then + case Data.fGlyphVAlign of + vaTop: + Inc(TextClipRect.Top, GlyphH); + vaBottom: + Dec(TextClipRect.Bottom, GlyphH); + vaCenter: + case Data.fGlyphHAlign of + haLeft: + Inc(TextClipRect.Left, GlyphW); + haRight: + Dec(TextClipRect.Right, GlyphW); + haCenter: + if aDrawText then + aDrawGlyph := False; + end; + end + else + case Data.fGlyphHAlign of + haLeft: + Inc(TextClipRect.Left, GlyphW); + haRight: + Dec(TextClipRect.Right, GlyphW); + haCenter: + case Data.fGlyphVAlign of + vaTop: + Inc(TextClipRect.Top, GlyphH); + vaBottom: + Dec(TextClipRect.Bottom, GlyphH); + vaCenter: + if aDrawText then + aDrawGlyph := False; + end; + end; + end; + {$ELSE ALLOW_GLYPH} + aDrawText := Data.fDrawText and ((Caption <> '') or (Data.fDrawProgress)); + {$ENDIF ALLOW_GLYPH} + MaxMin4(Data, M, N); + TextClipRect := AddRects(TextClipRect, MakeRect(-N, -N, -M, -M)); + _TextRect := TextClipRect; + + aDrawText := aDrawText and (_TextRect.Right - _TextRect.Left > 2) + and (_TextRect.Bottom - _TextRect.Top > 2); + + with Bitmap.Canvas^ do begin + Brush.BrushStyle := bsClear; + if {(Data.fControlType = ctProgressBar) and} Data.fDrawProgressRect then begin + Pen.PenStyle := psSolid; + Pen.Color := State.BorderColor; + Rectangle(0, 0, W, H); + end; + + if aDrawText then begin + if Data.fDrawProgress then + Cpt := Format('%d%s',[Data.fProgress, Caption]) + else + Cpt := Caption; + //Bitmap.Canvas.Pen.PenStyle := psClear; // + //Bitmap.Canvas.Brush.Color := clGreen; // + //Bitmap.Canvas.Rectangle(TextClipRect.Left, TextClipRect.Top, TextClipRect.Right, TextClipRect.Bottom); // + Font.Assign(Self.Font); + DrawText(Cpt, _TextRect, DT_EDITCONTROL or DT_CALCRECT or DT_WORDBREAK + or {$IFDEF GRUSH_WORD_ELLIPSIS} DT_WORD_ELLIPSIS + {$ELSE} DT_END_ELLIPSIS + {$ENDIF}); + IntersectRect(_TextRect, _TextRect, TextClipRect); + + _ti := TextHeight('_'); + _TextRect.Bottom := _TextRect.Bottom - ((_TextRect.Bottom - _TextRect.Top) mod _ti); + if _TextRect.Bottom = _TextRect.Top then + _TextRect.Bottom := _TextRect.Top + _ti; + + AlignRect(_TextRect, TextClipRect, Data.fTextVAlign, Data.fTextHAlign); + Flags := DT_EDITCONTROL + DT_WORDBREAK + + {$IFDEF GRUSH_WORD_ELLIPSIS} DT_WORD_ELLIPSIS + {$ELSE} DT_END_ELLIPSIS + {$ENDIF} or integer(Data.fTextHAlign); + + Font.Color := State.ColorShadow; + OffsetRect(_TextRect, State.ShadowOffset, State.ShadowOffset); + Bitmap.Canvas.DrawText(Cpt, _TextRect, Flags); + + Font.Color := State.ColorText; + OffsetRect(_TextRect, -State.ShadowOffset, -State.ShadowOffset); + Bitmap.Canvas.DrawText(Cpt, _TextRect, Flags); +// TextClipRect := AddRects(_TextRect, MakeRect(N, N, M, M)); + end; + + {$IFDEF ALLOW_GLYPH} + if aDrawGlyph then begin + with Data.fGlyphBitmap^ do begin + GlyphW := Data.fGlyphWidth; + GlyphH := Data.fGlyphHeight; + if Data.fGlyphAttached then begin + + end else begin + GlyphRect := MakeRect(0, 0, GlyphW, GlyphH); + AlignRect(GlyphRect, ContentRect, Data.fGlyphVAlign, Data.fGlyphHAlign); + end; + + //Draw(Bitmap.Canvas.Handle, GlyphRect.Left, GlyphRect.Top); + + {$IFDEF FIX_16BITMODE} ///////////// +++ tool bar buttons!64K colors! + TBM := NewDibBitMap(GlyphW, GlyphH, pf32bit); + {$ELSE} + TBM := NewBitMap(GlyphW, GlyphH); + {$ENDIF FIX_16BITMODE} + R1 := MakeRect(0, 0, GlyphW, GlyphH); + R2 := R1; + OffsetRect(R2, State.GlyphItemX*GlyphW, State.GlyphItemY*GlyphH); + TBM.Canvas.CopyRect(R1, Canvas, R2); + {$IFDEF FIX_DRAWTRANSPARENT} + myDrawTransparent(TBM, Bitmap.Canvas.Handle, GlyphRect.Left, GlyphRect.Top, Pixels[0,0]); + {$ELSE FIX_DRAWTRANSPARENT} + TBM.DrawTransparent(Bitmap.Canvas.Handle, GlyphRect.Left, GlyphRect.Top, Pixels[0,0]); + {$ENDIF FIX_DRAWTRANSPARENT} + TBM.Free; + end; + end; + {$ENDIF ALLOW_GLYPH} + Brush.BrushStyle := bsSolid; + Brush.Color := clGray; + for i := 0 to Data.fSplitterDotsCount-1 do begin + M := ((W - 3) div 2); + N := ((H - 3) div 2); + if (Align in [caLeft, caRight]) or + ( (Align = caNone) and + (Data.fSplDotsOrient = orVertical) + ) then + N := Atom1(H, i, Data.fSplitterDotsCount) + else + M := Atom1(W, i, Data.fSplitterDotsCount); + FillRect(MakeRect(M, N, M + 3, N + 3)); + Pixels[M, N] := clWhite; + end; + end; + + (*{$IFDEF NOT_IMMIDIATLYONLY} + if UseDIB then begin + {$IFDEF FIX_16BITMODE} + TBM := NewDIBBitmap(W, H, pf32bit); + {$ELSE} + TBM := NewDIBBitmap(W, H, pf16bit); + {$ENDIF FIX_16BITMODE} + Bitmap.Draw(TBM.Canvas.Handle, 0, 0); + Bitmap.Free; + Bitmap := TBM; + end; + {$ENDIF NOT_IMMIDIATLYONLY}*) + Bitmap.RemoveCanvas; + //Tag := Tag + 1; +end; + +procedure TGRushControl.CheckNeedUpdate(ToUpdate: TGRushToUpdate; UseDIBs: Boolean); +var Data: PGRushData; +begin + Data := PGRushData(CustomObj); + if Data.fDefNeedUpdate and (tuDef in ToUpdate) then begin + DrawControlState(Data.fDefPatern, Data.fRects.DefBorderRect, Data.fPSDef, UseDIBs); + Data.fDefNeedUpdate := false; + end; + if Data.fOverNeedUpdate and (tuOver in ToUpdate) then begin + DrawControlState(Data.fOverPatern, Data.fRects.OverBorderRect, Data.fPSOver, UseDIBs); + Data.fOverNeedUpdate := false; + end; + if Data.fDownNeedUpdate and (tuDown in ToUpdate) then begin + DrawControlState(Data.fDownPatern, Data.fRects.DownBorderRect, Data.fPSDown, UseDIBs); + Data.fDownNeedUpdate := false; + end; + if Data.fDisNeedUpdate and (tuDis in ToUpdate) then begin + DrawControlState(Data.fDisPatern, Data.fRects.DisBorderRect, Data.fPSDis, FALSE); + Data.fDisNeedUpdate := false; + end; +end; + +{$IFDEF NOT_IMMIDIATLYONLY} +procedure TGRushControl.TimerEvent(Data: PGRushData); +var FromBitmap: PBitmap; + ToBitmap: PBitmap; + W, H: Integer; + //SrcDC, DstDC: HDC; +begin + if not Visible then Exit; + case Data.fCurrentOperation of + coDefToDown, coDefToOver: + begin + CheckNeedUpdate([tuDef], true); + FromBitmap := Data.fDefPatern; + end; + coOverToDef, coOverToDown: + begin + CheckNeedUpdate([tuOver], true); + FromBitmap := Data.fOverPatern; + end; + coDownToDef, coDownToOver: + begin + CheckNeedUpdate([tuDown], true); + FromBitmap := Data.fDownPatern; + end; + else exit; + end; + case Data.fCurrentOperation of + coOverToDef, coDownToDef: + begin + CheckNeedUpdate([tuDef], true); + ToBitmap := Data.fDefPatern; + end; + coDefToOver, coDownToOver: + begin + CheckNeedUpdate([tuOver], true); + ToBitmap := Data.fOverPatern; + end; + coDefToDown, coOverToDown: + begin + CheckNeedUpdate([tuDown], true); + ToBitmap := Data.fDownPatern; + end; + else exit; + end; + + W := ToBitmap.Width; + H := ToBitmap.Height; + if (W > 0) and (H > 0) then + begin + if Data.fResultPatern = nil then + Data.fResultPatern := NewDIBBitmap(W, H, pf32bit); + with Data.fRects.AlphaRect, Data^ do + if (Left < Right) and (Top < Bottom) then + if (Left>0) or (Top>0) or (Width > Right) or (Height > Bottom) then begin + CheckNeedUpdate([tuDef], true); + {SrcDC := fDefPatern.Canvas.Handle; + DstDC := fResultPatern.Canvas.Handle; + BitBlt(DstDC, 0, 0, Right, Top, SrcDC, 0, 0, SRCCOPY); + BitBlt(DstDC, Right, 0, W, Bottom, SrcDC, Right, 0, SRCCOPY); + BitBlt(DstDC, Left, Bottom, W, H, SrcDC, Left, Bottom, SRCCOPY); + BitBlt(DstDC, 0, Top, Left, H, SrcDC, 0, Top, SRCCOPY); } + fDefPatern.Draw (fResultPatern.Canvas.Handle, 0, 0); + end; + BlendBitmaps(Data.fResultPatern, FromBitmap, ToBitmap, Data.fBlendPercent, Data.fRects.AlphaRect); + end; + Data.fResultNeedUpdate := FALSE; + {$IFDEF USE_MEMSAVEMODE} + if (Data.fCurrentOperation in [coOverToDef, coDownToDef]) and (Data.fBlendPercent >= 64) then begin + CleanMem(Data); + end; + {$ENDIF} +end; +{$ELSE NOT_IMMIDIATLYONLY} +procedure TGRushControl.TimerEvent(Data: PGRushData); +var ToBitmap: PBitmap; + W, H: Integer; +begin + case Data.fCurrentOperation of + coOverToDef, coDownToDef: + begin + CheckNeedUpdate([tuDef], true); + ToBitmap := Data.fDefPatern; + end; + coDefToOver, coDownToOver: + begin + CheckNeedUpdate([tuOver], true); + ToBitmap := Data.fOverPatern; + end; + coDefToDown, coOverToDown: + begin + CheckNeedUpdate([tuDown], true); + ToBitmap := Data.fDownPatern; + end; + else exit; + end; + + W := ToBitmap.Width; + H := ToBitmap.Height; + if Data.fResultPatern = nil then + Data.fResultPatern := NewBitmap(W, H); + with Data.fRects.AlphaRect, Data^ do + if (Left>0) or (Top>0) or (Width > Right) or (Height > Bottom) then begin + CheckNeedUpdate([tuDef], true); + fDefPatern.Draw (fResultPatern.Canvas.Handle, 0, 0); + end; + Data.fResultPatern.CopyRect(Data.fRects.AlphaRect, ToBitmap, Data.fRects.AlphaRect); + Data.fResultNeedUpdate := false; + Invalidate; +end; +{$ENDIF NOT_IMMIDIATLYONLY} + +procedure TGrushControl.UpdateProgress; +var Data: PGRushData; + tH: integer; +begin + //Data := CustomData; + Data := PGRushData(CustomObj); + with Data^ do begin + if Data.fProgressVertical then + tH := Height + else + tH := Width; + if tH <= 2 then exit; + if fProgressRange > 0 then + tH := (INT64(tH - 2) * fProgress) div fProgressRange + else + tH := 0; + if Data.fProgressVertical then + fRects.DefBorderRect := MakeRect(0, Height-tH-1, Width, Height) + else + fRects.DefBorderRect := MakeRect(1, 0, tH+1, Height); + fRects.DisBorderRect := fRects.DefBorderRect; + end; + if assigned(Data.fOnRecalcRects) then + Data.fOnRecalcRects(@Self, Data.fRects); + SetAllNeedUpdate; +end; + +procedure TGRushControl.CleanMem(Data: PGRushData); +begin + Free_And_Nil(Data.fOverPatern); + Data.fOverNeedUpdate := TRUE; + Free_And_Nil(Data.fDownPatern); + Data.fDownNeedUpdate := TRUE; + Free_And_Nil(Data.fResultPatern); + Data.fResultNeedUpdate := TRUE; +end; + +procedure TGRushControl.DoPaint( Ctl_: PControl; DC:HDC ); +var Data: PGRushData; + {$IFDEF ALLOW_CONTROLSTRANSPARANSY} + TransColor: TColor; + {$ENDIF ALLOW_CONTROLSTRANSPARANSY} + _Rgn: HRGN; + tH: DWORD; + RG: HRGN; + cx, cy: integer; + ContentRect: TRect; +begin + Data := PGRushData(CustomObj); + {$IFDEF ALLOW_CONTROLSTRANSPARANSY} + TransColor := Data.fPSDef.ColorOuter; + {$ENDIF ALLOW_CONTROLSTRANSPARANSY} + if not Enabled then begin + {$IFDEF USE_MEMSAVEMODE} + CleanMem(Data); + Free_And_Nil(Data.fDefPatern); + Data.fDefNeedUpdate := TRUE; + {$ENDIF USE_MEMSAVEMODE} + CheckNeedUpdate([tuDis], false); + {$IFDEF ALLOW_CONTROLSTRANSPARANSY} + if Transparent then + {$IFDEF FIX_DRAWTRANSPARENT} + myDrawTransparent(Data.fDisPatern, DC, 0, 0, TransColor) + {$ELSE FIX_DRAWTRANSPARENT} + Data.fDisPatern.DrawTransparent(DC, 0, 0, TransColor) + {$ENDIF FIX_DRAWTRANSPARENT} + else + {$ENDIF ALLOW_CONTROLSTRANSPARANSY} + Data.fDisPatern.Draw(DC, 0, 0); + end else begin + if Data.fResultNeedUpdate then begin + {$IFDEF USE_MEMSAVEMODE} + Free_And_Nil(Data.fDisPatern); + Data.fDisNeedUpdate := TRUE; + {$ENDIF USE_MEMSAVEMODE} + CheckNeedUpdate([tuDef], Data.fNeedDib); + {$IFDEF ALLOW_CONTROLSTRANSPARANSY} + if Transparent then begin + {$IFDEF FIX_DRAWTRANSPARENT} + myDrawTransparent(Data.fDefPatern, DC, 0, 0, TransColor) + {$ELSE FIX_DRAWTRANSPARENT} + Data.fDefPatern.DrawTransparent(DC, 0, 0, TransColor) + {$ENDIF FIX_DRAWTRANSPARENT} + end else + {$ENDIF ALLOW_CONTROLSTRANSPARANSY} + Data.fDefPatern.Draw(DC, 0, 0); + end else + {$IFDEF ALLOW_CONTROLSTRANSPARANSY} + if Transparent then + {$IFDEF FIX_DRAWTRANSPARENT} + myDrawTransparent(Data.fResultPatern, DC, 0, 0, TransColor) + {$ELSE FIX_DRAWTRANSPARENT} + Data.fResultPatern.DrawTransparent(DC, 0, 0, TransColor) + {$ENDIF FIX_DRAWTRANSPARENT} + else + {$ENDIF ALLOW_CONTROLSTRANSPARANSY} + Data.fResultPatern.Draw(DC, 0, 0); + end; + + if Checked then begin + tH := CreateSolidBrush(Data.fColorCheck); + RG := CreateRectRgn(0, 0, 0, 0); + if Data.fControlType = ctRadioBox then + _Rgn := RadioRgn + else + _Rgn := CheckRgn; + CombineRgn(RG, _Rgn, 0, RGN_COPY); + with Data.fRects.DefBorderRect do begin + cx := (Right + Left - 17) div 2; + cy := (Bottom + Top - 11) div 2; + end; + OffsetRgn(RG, cx, cy); + FillRgn(DC, RG, tH); + DeleteObject(RG); + DeleteObject(tH); + end; + + if Data.fActive and Data.fDrawFocusRect then begin + ContentRect := AddRects(ClientRect, Data.fContentOffsets); + InflateRect(ContentRect, 1, 1); + DrawFocusRect(DC, ContentRect); + end; + + {Canvas.Brush.Color := clRed; + if Data.fDefNeedUpdate then + Canvas.Rectangle(2, 2, 6, 6); + if Data.fOverNeedUpdate then + Canvas.Rectangle(8, 2, 12, 6); + if Data.fDownNeedUpdate then + Canvas.Rectangle(14, 2, 18, 6); + if Data.fDisNeedUpdate then + Canvas.Rectangle(20, 2, 24, 6); + if Data.fResultNeedUpdate then + Canvas.Rectangle(26, 2, 30, 6); + + Canvas.Brush.Color := clLime; + if Data.fDefPatern = nil then + Canvas.Rectangle(2, 8, 6, 12); + if Data.fOverPatern = nil then + Canvas.Rectangle(8, 8, 12, 12); + if Data.fDownPatern = nil then + Canvas.Rectangle(14, 8, 18, 12); + if Data.fDisPatern = nil then + Canvas.Rectangle(20, 8, 24, 12); + if Data.fResultPatern = nil then + Canvas.Rectangle(26, 8, 30, 12);} + + //TextOut(DC, 0, 0, Pchar(int2Str(Tag)), Length(int2Str(Tag))); + //Tag := Tag + 1; + //GDIFlush(); + //sleep(50); +end; + +function WndProcGRush(Ctl_: PGRushControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var Data: PGRushData; + tH: DWORD; + TU: TGRushToUpdate; + ChM: DWORD; + H: DWORD; +begin + result := FALSE; + + Data := PGRushData(Ctl_.CustomObj); + + if (Msg.message > WM_MOUSEFIRST) and (Msg.Message < WM_MOUSELAST) and (not Data.fNeedDib) then + exit; + + case Msg.message of + BM_GETCHECK: + begin + //if Data.fControlType in [ctCheckBox, ctRadioBox] then + Rslt := Integer(Ctl_.fChecked); + Result := TRUE; + end; + BM_SETCHECK: + {+/-}//if Data.fControlType in [ctCheckBox, ctRadioBox] then + begin + Ctl_.fChecked := Boolean(Msg.wParam); + if Boolean(Msg.wParam) then + Ctl_.DeactivateSublings; + Ctl_.Invalidate; + Result := TRUE; + end; + PBM_GETPOS: + {if Data.fControlType = ctProgressBar then} begin + Rslt := Data.fProgress; + Result := TRUE; + end; + PBM_SETPOS: + {if Data.fControlType = ctProgressBar then} begin + Rslt := Data.fProgress; + if Msg.wParam > 0 then + Data.fProgress := Msg.wParam + else + Data.fProgress := 0; + if Data.fProgress > Data.fProgressRange then + Data.fProgress := Data.fProgressRange; + PGrushControl(Ctl_).UpdateProgress; + if Assigned(Data.fOnProgressChange) then + Data.fOnProgressChange(Ctl_); + Result := TRUE; + end; + PBM_GETRANGE: + begin + {if Msg.wParam > 0 then + Rslt := 0 + else } + Rslt := Data.fProgressRange; + Result := TRUE; + end; + PBM_SETRANGE32: + begin + Data.fProgressRange := Msg.lParam; + PGrushControl(Ctl_).UpdateProgress; + Result := TRUE; + end; + WM_SETTEXT: + PGRushControl(Ctl_).SetAllNeedUpdate; + WM_SIZE: + with Data^ do begin + Free_And_Nil(Data.fResultPatern); + PGRushControl(Ctl_).SetAllNeedUpdate; + if fControlType in [ctCheckBox, ctRadioBox] then begin + tH := Ctl_.Height; + ChM := fCheckMetric; + if ChM > tH then + ChM := tH; + H := (tH - ChM) div 2; + fRects.DefBorderRect := MakeRect(2, H, 2+ChM, H+ChM); + end else + fRects.DefBorderRect := Ctl_.ClientRect; + fRects.OverBorderRect := fRects.DefBorderRect; + fRects.DownBorderRect := fRects.DefBorderRect; + fRects.DisBorderRect := fRects.DefBorderRect; + fRects.AlphaRect := Ctl_.ClientRect; + if fControlType = ctProgressBar then + PGrushControl(Ctl_).UpdateProgress + else if assigned(Data.fOnRecalcRects) then + Data.fOnRecalcRects(PGRushControl(Ctl_), Data.fRects); + Ctl_.Invalidate; + end; + WM_NCDESTROY: + begin + RemoveProp( Ctl_.fHandle, ID_GRUSHTYPE ); + end; + WM_CREATE: + begin + SetProp(Ctl_.Handle, ID_GRUSHTYPE, DWORD(Data.fControlType)); + end; + WM_SHOWWINDOW: + begin + if Ctl_.Enabled then + TU := [tuDef] + else + TU := [tuDis]; + Ctl_.CheckNeedUpdate(TU, Data.fNeedDib); + end; + {$IFDEF NOT_IMMIDIATLYONLY} + WM_TIMER: + if Msg.wParam = 8 then begin + Rslt := 0; + Result := true; + inc(Data.fBlendPercent, AlphaIncrement[Data.fUpdateSpeed]); + if Data.fBlendPercent >= 64 then begin + Data.fBlendPercent := 64; + KillTimer(Ctl_.Handle, 8); + end; + Ctl_.TimerEvent(Data); + Ctl_.Invalidate; + end; + {$ENDIF NOT_IMMIDIATLYONLY} + WM_RBUTTONDOWN: + if not Ctl_.Focused then begin + Ctl_.Focused:=true; + Ctl_.Invalidate; + end; + WM_LBUTTONDOWN: + if ((Data.fStateInit = siNone) or (Ctl_.Focused = false)) then begin + Ctl_.Focused:=true; + Data.fStateInit := siButton; + PGRushControl(Ctl_).DoPush; + end; + WM_LBUTTONUP: + if (Data.fStateInit = siButton) then begin + PGRushControl(Ctl_).DoPop; + Data.fStateInit := siNone; + end; + WM_KEYDOWN: + if (Msg.wParam = 32) and (Data.fStateInit = siNone) then begin + Data.fStateInit := siKey; + PGRushControl(Ctl_).DoPush; + end; + WM_KEYUP: + if (Msg.wParam = 32) and (Data.fStateInit = siKey) then begin + PGRushControl(Ctl_).DoPop; + Data.fStateInit := siNone; + end; + WM_SETFOCUS: + begin + Data.fActive := true; + Ctl_.Invalidate; + end; + WM_KILLFOCUS: + begin + if (Data.fStateInit = siKey) then begin + Data.fStateInit := siButton; + PGRushControl(Ctl_).fOnMouseLeave(Ctl_); + Data.fStateInit := siNone; + end; + Data.fActive := false; + Ctl_.Invalidate; + end; + $031A {WM_THEMECHANGED}: + begin + PGRushControl(Ctl_).SetAllNeedUpdate; + Ctl_.Invalidate; + end; + end; +end; + +function TGRushControl.GetDef_ColorFrom; + begin Result := PGRushData(CustomObj).fPSDef.ColorFrom; end; +procedure TGRushControl.SetDef_ColorFrom; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ColorFrom := Val; end; +function TGRushControl.GetDef_ColorTo; + begin Result := PGRushData(CustomObj).fPSDef.ColorTo; end; +procedure TGRushControl.SetDef_ColorTo; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ColorTo := Val; end; +function TGRushControl.GetDef_ColorOuter; + begin Result := PGRushData(CustomObj).fPSDef.ColorOuter; end; +procedure TGRushControl.SetDef_ColorOuter; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ColorOuter := Val; end; +function TGRushControl.GetDef_ColorText; + begin Result := PGRushData(CustomObj).fPSDef.ColorText; end; +procedure TGRushControl.SetDef_ColorText; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ColorText := Val; end; +function TGRushControl.GetDef_ColorShadow; + begin Result := PGRushData(CustomObj).fPSDef.ColorShadow;end; +procedure TGRushControl.SetDef_ColorShadow; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ColorShadow := Val; end; +function TGRushControl.GetDef_BorderColor; + begin Result := PGRushData(CustomObj).fPSDef.BorderColor;end; +procedure TGRushControl.SetDef_BorderColor; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.BorderColor := Val; end; +function TGRushControl.GetDef_BorderWidth; + begin Result := PGRushData(CustomObj).fPSDef.BorderWidth;end; +procedure TGRushControl.SetDef_BorderWidth; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.BorderWidth := Val; end; +function TGRushControl.GetDef_BorderRoundWidth; + begin Result := PGRushData(CustomObj).fPSDef.BorderRoundWidth;end; +procedure TGRushControl.SetDef_BorderRoundWidth; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.BorderRoundWidth := Val; end; +function TGRushControl.GetDef_BorderRoundHeight; + begin Result := PGRushData(CustomObj).fPSDef.BorderRoundHeight;end; +procedure TGRushControl.SetDef_BorderRoundHeight; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.BorderRoundHeight := Val; end; +function TGRushControl.GetDef_ShadowOffset; + begin Result := PGRushData(CustomObj).fPSDef.ShadowOffset; end; +procedure TGRushControl.SetDef_ShadowOffset; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.ShadowOffset := Val; end; +function TGRushControl.GetDef_GradientStyle; + begin Result := PGRushData(CustomObj).fPSDef.GradientStyle; end; +procedure TGRushControl.SetDef_GradientStyle; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.GradientStyle := Val; end; +function TGRushControl.GetDef_GlyphItemX; + begin Result := PGRushData(CustomObj).fPSDef.GlyphItemX; end; +procedure TGRushControl.SetDef_GlyphItemX; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.GlyphItemX := Val; end; +function TGRushControl.GetDef_GlyphItemY; + begin Result := PGRushData(CustomObj).fPSDef.GlyphItemY; end; +procedure TGRushControl.SetDef_GlyphItemY; + begin PGRushData(CustomObj).fDefNeedUpdate := true; + PGRushData(CustomObj).fPSDef.GlyphItemY := Val; end; + +function TGRushControl.GetOver_ColorFrom; + begin Result := PGRushData(CustomObj).fPSOver.ColorFrom;end; +procedure TGRushControl.SetOver_ColorFrom; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ColorFrom := Val; end; +function TGRushControl.GetOver_ColorTo; + begin Result := PGRushData(CustomObj).fPSOver.ColorTo;end; +procedure TGRushControl.SetOver_ColorTo; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ColorTo := Val; end; +function TGRushControl.GetOver_ColorOuter; + begin Result := PGRushData(CustomObj).fPSOver.ColorOuter;end; +procedure TGRushControl.SetOver_ColorOuter; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ColorOuter := Val; end; +function TGRushControl.GetOver_ColorText; + begin Result := PGRushData(CustomObj).fPSOver.ColorText;end; +procedure TGRushControl.SetOver_ColorText; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ColorText := Val; end; +function TGRushControl.GetOver_ColorShadow; + begin Result := PGRushData(CustomObj).fPSOver.ColorShadow;end; +procedure TGRushControl.SetOver_ColorShadow; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ColorShadow := Val; end; +function TGRushControl.GetOver_BorderColor; + begin Result := PGRushData(CustomObj).fPSOver.BorderColor;end; +procedure TGRushControl.SetOver_BorderColor; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.BorderColor := Val; end; +function TGRushControl.GetOver_BorderWidth; + begin Result := PGRushData(CustomObj).fPSOver.BorderWidth;end; + procedure TGRushControl.SetOver_BorderWidth; +begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.BorderWidth := Val; end; +function TGRushControl.GetOver_BorderRoundWidth; + begin Result := PGRushData(CustomObj).fPSOver.BorderRoundWidth;end; +procedure TGRushControl.SetOver_BorderRoundWidth; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.BorderRoundWidth := Val; end; +function TGRushControl.GetOver_BorderRoundHeight; + begin Result := PGRushData(CustomObj).fPSOver.BorderRoundHeight;end; +procedure TGRushControl.SetOver_BorderRoundHeight; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.BorderRoundHeight := Val; end; +function TGRushControl.GetOver_ShadowOffset; + begin Result := PGRushData(CustomObj).fPSOver.ShadowOffset;end; +procedure TGRushControl.SetOver_ShadowOffset; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.ShadowOffset := Val; end; +function TGRushControl.GetOver_GradientStyle; + begin Result := PGRushData(CustomObj).fPSOver.GradientStyle;end; +procedure TGRushControl.SetOver_GradientStyle; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.GradientStyle := Val; end; +function TGRushControl.GetOver_GlyphItemX; + begin Result := PGRushData(CustomObj).fPSOver.GlyphItemX;end; +procedure TGRushControl.SetOver_GlyphItemX; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.GlyphItemX := Val; end; +function TGRushControl.GetOver_GlyphItemY; + begin Result := PGRushData(CustomObj).fPSOver.GlyphItemY;end; +procedure TGRushControl.SetOver_GlyphItemY; + begin PGRushData(CustomObj).fOverNeedUpdate := true; + PGRushData(CustomObj).fPSOver.GlyphItemY := Val; end; + +function TGRushControl.GetDown_ColorFrom; + begin Result := PGRushData(CustomObj).fPSDown.ColorFrom;end; +procedure TGRushControl.SetDown_ColorFrom; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ColorFrom := Val; end; +function TGRushControl.GetDown_ColorTo; + begin Result := PGRushData(CustomObj).fPSDown.ColorTo;end; +procedure TGRushControl.SetDown_ColorTo; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ColorTo := Val; end; +function TGRushControl.GetDown_ColorOuter; + begin Result := PGRushData(CustomObj).fPSDown.ColorOuter;end; +procedure TGRushControl.SetDown_ColorOuter; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ColorOuter := Val; end; +function TGRushControl.GetDown_ColorText; + begin Result := PGRushData(CustomObj).fPSDown.ColorText;end; +procedure TGRushControl.SetDown_ColorText; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ColorText := Val; end; +function TGRushControl.GetDown_ColorShadow; + begin Result := PGRushData(CustomObj).fPSDown.ColorShadow;end; +procedure TGRushControl.SetDown_ColorShadow; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ColorShadow := Val; end; +function TGRushControl.GetDown_BorderColor; + begin Result := PGRushData(CustomObj).fPSDown.BorderColor;end; +procedure TGRushControl.SetDown_BorderColor; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.BorderColor := Val; end; +function TGRushControl.GetDown_BorderWidth; + begin Result := PGRushData(CustomObj).fPSDown.BorderWidth;end; +procedure TGRushControl.SetDown_BorderWidth; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.BorderWidth := Val; end; +function TGRushControl.GetDown_BorderRoundWidth; + begin Result := PGRushData(CustomObj).fPSDown.BorderRoundWidth;end; +procedure TGRushControl.SetDown_BorderRoundWidth; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.BorderRoundWidth := Val; end; +function TGRushControl.GetDown_BorderRoundHeight; + begin Result := PGRushData(CustomObj).fPSDown.BorderRoundHeight;end; +procedure TGRushControl.SetDown_BorderRoundHeight; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.BorderRoundHeight := Val; end; +function TGRushControl.GetDown_ShadowOffset; + begin Result := PGRushData(CustomObj).fPSDown.ShadowOffset;end; +procedure TGRushControl.SetDown_ShadowOffset; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.ShadowOffset := Val; end; +function TGRushControl.GetDown_GradientStyle; + begin Result := PGRushData(CustomObj).fPSDown.GradientStyle;end; +procedure TGRushControl.SetDown_GradientStyle; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.GradientStyle := Val; end; +function TGRushControl.GetDown_GlyphItemX; + begin Result := PGRushData(CustomObj).fPSDown.GlyphItemX;end; +procedure TGRushControl.SetDown_GlyphItemX; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.GlyphItemX := Val; end; +function TGRushControl.GetDown_GlyphItemY; + begin Result := PGRushData(CustomObj).fPSDown.GlyphItemY;end; +procedure TGRushControl.SetDown_GlyphItemY; + begin PGRushData(CustomObj).fDownNeedUpdate := true; + PGRushData(CustomObj).fPSDown.GlyphItemY := Val; end; + +function TGRushControl.GetDis_ColorFrom; + begin Result := PGRushData(CustomObj).fPSDis.ColorFrom;end; +procedure TGRushControl.SetDis_ColorFrom; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ColorFrom := Val; end; +function TGRushControl.GetDis_ColorTo; + begin Result := PGRushData(CustomObj).fPSDis.ColorTo;end; +procedure TGRushControl.SetDis_ColorTo; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ColorTo := Val; end; +function TGRushControl.GetDis_ColorOuter; + begin Result := PGRushData(CustomObj).fPSDis.ColorOuter;end; +procedure TGRushControl.SetDis_ColorOuter; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ColorOuter := Val; end; +function TGRushControl.GetDis_ColorText; + begin Result := PGRushData(CustomObj).fPSDis.ColorText;end; +procedure TGRushControl.SetDis_ColorText; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ColorText := Val; end; +function TGRushControl.GetDis_ColorShadow; + begin Result := PGRushData(CustomObj).fPSDis.ColorShadow;end; +procedure TGRushControl.SetDis_ColorShadow; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ColorShadow := Val; end; +function TGRushControl.GetDis_BorderColor; + begin Result := PGRushData(CustomObj).fPSDis.BorderColor;end; +procedure TGRushControl.SetDis_BorderColor; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.BorderColor := Val; end; +function TGRushControl.GetDis_BorderWidth; + begin Result := PGRushData(CustomObj).fPSDis.BorderWidth;end; +procedure TGRushControl.SetDis_BorderWidth; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.BorderWidth := Val; end; +function TGRushControl.GetDis_BorderRoundWidth; + begin Result := PGRushData(CustomObj).fPSDis.BorderRoundWidth;end; +procedure TGRushControl.SetDis_BorderRoundWidth; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.BorderRoundWidth := Val; end; +function TGRushControl.GetDis_BorderRoundHeight; + begin Result := PGRushData(CustomObj).fPSDis.BorderRoundHeight;end; +procedure TGRushControl.SetDis_BorderRoundHeight; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.BorderRoundHeight := Val; end; +function TGRushControl.GetDis_ShadowOffset; + begin Result := PGRushData(CustomObj).fPSDis.ShadowOffset;end; +procedure TGRushControl.SetDis_ShadowOffset; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.ShadowOffset := Val; end; +function TGRushControl.GetDis_GradientStyle; + begin Result := PGRushData(CustomObj).fPSDis.GradientStyle;end; +procedure TGRushControl.SetDis_GradientStyle; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.GradientStyle := Val; end; +function TGRushControl.GetDis_GlyphItemX; + begin Result := PGRushData(CustomObj).fPSDis.GlyphItemX;end; +procedure TGRushControl.SetDis_GlyphItemX; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.GlyphItemX := Val; end; +function TGRushControl.GetDis_GlyphItemY; + begin Result := PGRushData(CustomObj).fPSDis.GlyphItemY;end; +procedure TGRushControl.SetDis_GlyphItemY; + begin PGRushData(CustomObj).fDisNeedUpdate := true; + PGRushData(CustomObj).fPSDis.GlyphItemY := Val; end; + +function TGRushControl.GetAll_CheckMetric; + begin Result := PGRushData(CustomObj).fCheckMetric end; +procedure TGRushControl.SetAll_CheckMetric; +var Data: PGRushData; +begin + Data := PGRushData(CustomObj); + inc(Data.fContentOffsets.Left, Val-Data.fCheckMetric); + Data.fCheckMetric := Val; + Perform(WM_SIZE, 0, 0); +end; +procedure TGRushControl.SetAll_GlyphBitmap; +var Data: PGRushData; +begin + Data := PGRushData(CustomObj); + SetAllNeedUpdate; + if Data.fGlyphBitmap <> nil then + Data.fGlyphBitmap.RefDec; + Data.fGlyphBitmap := Val; + if Val = nil then exit; + Data.fGlyphWidth := Val.Width; + Data.fGlyphHeight := Val.Height; + Val.RefInc; +end; +function TGRushControl.GetAll_GlyphBitmap; + begin Result := PGRushData(CustomObj).fGlyphBitmap; end; +procedure TGRushControl.SetAll_ContentOffsets; + begin PGRushData(CustomObj).fContentOffsets := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_ContentOffsets; + begin Result := PGRushData(CustomObj).fContentOffsets; end; +procedure TGRushControl.SetAll_AntiAliasing; + begin PGRushData(CustomObj).fAntiAliasing := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_AntiAliasing; + begin Result := PGRushData(CustomObj).fAntiAliasing; end; +procedure TGRushControl.SetAll_GlyphVAlign; + begin PGRushData(CustomObj).fGlyphVAlign := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_GlyphVAlign; + begin Result := PGRushData(CustomObj).fGlyphVAlign; end; +procedure TGRushControl.SetAll_GlyphHAlign; + begin PGRushData(CustomObj).fGlyphHAlign := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_GlyphHAlign; + begin Result := PGRushData(CustomObj).fGlyphHAlign; end; +procedure TGRushControl.SetAll_TextVAlign; + begin PGRushData(CustomObj).fTextVAlign := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_TextVAlign; + begin Result := PGRushData(CustomObj).fTextVAlign; end; +procedure TGRushControl.SetAll_TextHAlign; + begin PGRushData(CustomObj).fTextHAlign := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_TextHAlign; + begin Result := PGRushData(CustomObj).fTextHAlign; end; + +procedure TGRushControl.SetAll_DrawText; + begin PGRushData(CustomObj).fDrawText := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_DrawText; + begin Result := PGRushData(CustomObj).fDrawText; end; +procedure TGRushControl.SetAll_DrawGlyph; + begin PGRushData(CustomObj).fDrawGlyph := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_DrawGlyph; + begin Result := PGRushData(CustomObj).fDrawGlyph; end; +procedure TGRushControl.SetAll_DrawFocusRect; + begin PGRushData(CustomObj).fDrawFocusRect := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_DrawFocusRect; + begin Result := PGRushData(CustomObj).fDrawFocusRect; end; +procedure TGRushControl.SetAll_DrawProgress; + begin PGRushData(CustomObj).fDrawProgress := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_DrawProgress; + begin Result := PGRushData(CustomObj).fDrawProgress; end; +procedure TGRushControl.SetAll_DrawProgressRect; + begin PGRushData(CustomObj).fDrawProgressRect := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_DrawProgressRect; + begin Result := PGRushData(CustomObj).fDrawProgressRect; end; +procedure TGRushControl.SetAll_ProgressVertical; + begin + if PGRushData(CustomObj).fControlType <> ctProgressBar then exit; + PGRushData(CustomObj).fProgressVertical := Val; + All_BorderWidth := 1; + if Val then begin + All_BorderRoundWidth := 25; + All_BorderRoundHeight := 4; + SetAll_GradientStyle(gsDoubleHorz) + end else begin + All_BorderRoundWidth := 4; + All_BorderRoundHeight := 25; + SetAll_GradientStyle(gsDoubleVert); + end;end; +function TGRushControl.GetAll_ProgressVertical; + begin Result := PGRushData(CustomObj).fProgressVertical; end; +procedure TGRushControl.SetAll_UpdateSpeed; + begin PGRushData(CustomObj).fUpdateSpeed := Val; end; +function TGRushControl.GetAll_UpdateSpeed; + begin Result := PGRushData(CustomObj).fUpdateSpeed; end; +procedure TGRushControl.SetAll_ColorCheck; + begin PGRushData(CustomObj).fColorCheck := Val; end; +function TGRushControl.GetAll_ColorCheck; + begin Result := PGRushData(CustomObj).fColorCheck; end; +procedure TGRushControl.SetAll_GlyphWidth; + begin PGRushData(CustomObj).fGlyphWidth := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_GlyphWidth; + begin Result := PGRushData(CustomObj).fGlyphWidth; end; +procedure TGRushControl.SetAll_GlyphHeight; + begin PGRushData(CustomObj).fGlyphHeight := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_GlyphHeight; + begin Result := PGRushData(CustomObj).fGlyphHeight; end; +procedure TGRushControl.SetAll_Spacing; + begin PGRushData(CustomObj).fSpacing := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_Spacing; + begin Result := PGRushData(CustomObj).fSpacing; end; +procedure TGRushControl.SetAll_SplitterDotsCount; + begin PGRushData(CustomObj).fSplitterDotsCount := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_SplitterDotsCount; + begin Result := PGRushData(CustomObj).fSplitterDotsCount; end; +procedure TGRushControl.SetAll_CropTopFirst; + begin PGRushData(CustomObj).fCropTopFirst := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_CropTopFirst; + begin Result := PGRushData(CustomObj).fCropTopFirst; end; +procedure TGRushControl.SetAll_GlyphAttached; + begin PGRushData(CustomObj).fGlyphAttached := Val; + SetAllNeedUpdate; end; +function TGRushControl.GetAll_GlyphAttached; + begin Result := PGRushData(CustomObj).fGlyphAttached; end; + +procedure TGRushControl.SetAllNeedUpdate; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fDefNeedUpdate := true; + Data.fOverNeedUpdate := true; Data.fDownNeedUpdate := true; + Data.fResultNeedUpdate := true; + Data.fDisNeedUpdate := true; end; +procedure TGRushControl.SetAll_ColorFrom; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.ColorFrom := Val; + Data.fPSOver.ColorFrom := Val; Data.fPSDown.ColorFrom := Val; + Data.fPSDis.ColorFrom := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_ColorTo; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.ColorTo := Val; + Data.fPSOver.ColorTo := Val; Data.fPSDown.ColorTo := Val; + Data.fPSDis.ColorTo := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_ColorOuter; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); + Data.fPSDef.ColorOuter := Val; Data.fPSOver.ColorOuter := Val; + Data.fPSDown.ColorOuter := Val; Data.fPSDis.ColorOuter := Val; + SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_ColorText; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.ColorText := Val; + Data.fPSOver.ColorText := Val; Data.fPSDown.ColorText := Val; + Data.fPSDis.ColorText := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_ColorShadow; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.ColorShadow := Val; + Data.fPSOver.ColorShadow := Val; Data.fPSDown.ColorShadow := Val; + Data.fPSDis.ColorShadow := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_BorderColor; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.BorderColor := Val; + Data.fPSOver.BorderColor := Val; Data.fPSDown.BorderColor := Val; + Data.fPSDis.BorderColor := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_BorderWidth; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.BorderWidth := Val; + Data.fPSOver.BorderWidth := Val; Data.fPSDown.BorderWidth := Val; + Data.fPSDis.BorderWidth := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_BorderRoundWidth; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.BorderRoundWidth := Val; + Data.fPSOver.BorderRoundWidth := Val; Data.fPSDown.BorderRoundWidth := Val; + Data.fPSDis.BorderRoundWidth := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_BorderRoundHeight; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.BorderRoundHeight := Val; + Data.fPSOver.BorderRoundHeight := Val; Data.fPSDown.BorderRoundHeight := Val; + Data.fPSDis.BorderRoundHeight := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_GradientStyle; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.GradientStyle := Val; + Data.fPSOver.GradientStyle := Val; Data.fPSDown.GradientStyle := Val; + Data.fPSDis.GradientStyle := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_ShadowOffset; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.ShadowOffset := Val; + Data.fPSOver.ShadowOffset := Val; Data.fPSDown.ShadowOffset := Val; + Data.fPSDis.ShadowOffset := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_GlyphItemX; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.GlyphItemX := Val; + Data.fPSOver.GlyphItemX := Val; Data.fPSDown.GlyphItemX := Val; + Data.fPSDis.GlyphItemX := Val; SetAllNeedUpdate; end; +procedure TGRushControl.SetAll_GlyphItemY; + var Data: PGRushData; + begin Data := PGRushData(CustomObj); Data.fPSDef.GlyphItemY := Val; + Data.fPSOver.GlyphItemY := Val; Data.fPSDown.GlyphItemY := Val; + Data.fPSDis.GlyphItemY := Val; SetAllNeedUpdate; end; +function TGRushControl.GetOnRecalcRects; + begin result := PGRushData(CustomObj).fOnRecalcRects; end; +procedure TGRushControl.SetOnRecalcRects; + begin PGRushData(CustomObj).fOnRecalcRects := val; + Perform(WM_SIZE, 0, 0); end; +function TGRushControl.GetOnProgressChange; + begin result := PGRushData(CustomObj).fOnProgressChange; end; +procedure TGRushControl.SetOnProgressChange; + begin PGRushData(CustomObj).fOnProgressChange := val; + Perform(PBM_SETPOS, Progress, 0); end; + + +procedure TGRushControl.DoEnter; +begin + with PGRushData(CustomObj)^ do begin + if (fControlType in [ctSplitter]) and (gsDown in fState) then + exit; + include(fState, gsOver); + if fStateInit = siKey then + exit; + {$IFDEF NOT_IMMIDIATLYONLY} + if fCurrentOperation = coOverToDef then + fBlendPercent := 64 - fBlendPercent + else + fBlendPercent := 0; + fCurrentOperation := coDefToOver; + KillTimer(Handle, 8); + SetTimer(Handle, 8, 40, nil); + Perform(WM_TIMER, 8, 0); + {$ELSE NOT_IMMIDIATLYONLY} + fCurrentOperation := coDefToOver; + TimerEvent(PGRushData(CustomObj)); + {$ENDIF NOT_IMMIDIATLYONLY} + end; +end; + +procedure TGRushControl.DoExit; +begin + with PGRushData(CustomObj)^ do begin + if (fControlType in [ctSplitter]) and (gsDown in fState) then + exit; + exclude(fState, gsOver); + if fStateInit = siKey then + exit; + fStateInit := siNone; + {$IFDEF NOT_IMMIDIATLYONLY} + if fCurrentOperation = coDefToOver then + fBlendPercent := 64 - fBlendPercent + else + fBlendPercent := 0; + if gsDown in fState then + fCurrentOperation := coDownToDef + else + fCurrentOperation := coOverToDef; + exclude(fState, gsDown); + KillTimer(Handle, 8); + SetTimer(Handle, 8, 40, nil); + Perform(WM_TIMER, 8, 0); + {$ELSE NOT_IMMIDIATLYONLY} + fCurrentOperation := coDownToDef; + exclude(fState, gsDown); + TimerEvent(PGRushData(CustomObj)); + {$ENDIF NOT_IMMIDIATLYONLY} + end; +end; + +procedure TGRushControl.DoPush; +begin + with PGRushData(CustomObj)^ do begin + include(fState, gsDown); + {$IFDEF NOT_IMMIDIATLYONLY} + if fCurrentOperation in [coDownToOver{, coDownToDef}] then + fBlendPercent := 64 - fBlendPercent + else + fBlendPercent := 0; + if gsOver in fState then + fCurrentOperation := coOverToDown + else + fCurrentOperation := coDefToDown; + KillTimer(Handle, 8); + SetTimer(Handle, 8, 40, nil); + Perform(WM_TIMER, 8, 0); + {$ELSE NOT_IMMIDIATLYONLY} + fCurrentOperation := coDefToDown; + TimerEvent(PGRushData(CustomObj)); + {$ENDIF NOT_IMMIDIATLYONLY} + end; +end; + +procedure TGRushControl.DoPop; +begin + with PGRushData(CustomObj)^ do begin + if not (gsDown in fState) then + exit; + exclude(fState, gsDown); + if fControlType = ctCheckBox then + Checked := not Checked; + if fControlType = ctRadioBox then + Checked := true; + {$IFDEF NOT_IMMIDIATLYONLY} + if fCurrentOperation in [coOverToDown{, coDefToDown}] then + fBlendPercent := 64 - fBlendPercent + else + fBlendPercent := 0; + {$ENDIF NOT_IMMIDIATLYONLY} + if gsOver in fState then + fCurrentOperation := coDownToOver + else + fCurrentOperation := coDownToDef; + {$IFDEF NOT_IMMIDIATLYONLY} + KillTimer(Handle, 8); + SetTimer(Handle, 8, 40, nil); + Perform(WM_TIMER, 8, 0); + {$ELSE NOT_IMMIDIATLYONLY} + TimerEvent(PGRushData(CustomObj)); + {$ENDIF NOT_IMMIDIATLYONLY} + if assigned(fOnClick) then + fOnClick(@Self); + end; +end; + +procedure TGRushControl.DeActivateSublings; +var i: integer; + Chl: PGrushControl; + GT: DWORD; +begin + with PGRushData(CustomObj)^ do begin + GT := GetProp(Handle, ID_GRUSHTYPE); + if (Parent <> nil) and (GT = GT_RADIOBOX) then + for i := 0 to Parent.ChildCount-1 do begin + Chl := PGrushControl(Parent.Children[i]); + if (Chl <> nil) and (Chl.Handle <> 0) and (Chl <> @Self) then + if GetProp(Chl.Handle, ID_GRUSHTYPE) = GT then + Chl.SetChecked(false); + end; + end; +end; + +procedure DefRecalcRect(self: PObj; Sender: PGRushControl; var Rects: TGRushRects ); +begin + InflateRect(Rects.AlphaRect, -3, -3); +end; + +procedure TGRushControl.VoidRecalcRect(Sender: PGRushControl; var Rects: TGRushRects ); +begin +end; + +procedure TGRushControl.InitLast(MEnterExit: Boolean; CT: TGRushControlType); +var Data: PGRushData; + //W: DWORD; +begin + New(Data, Create); + //W := DWORD(@(Data.fColorCheck)) - DWORD(@(Data.fPSDef.ColorFrom)); + //MessageBox(0, PChar(int2str(W)), nil ,0); + Move(DefGRushData, Data.fPSDef , Sizeof(TGRushFake)); + CustomObj := Data; + Data.fControlType := CT; + Data.fNeedDib := not (CT in [ctPanel, ctProgressBar]); + if CT in [ctCheckBox, ctRadioBox] then begin + Data.fTextHAlign := haLeft; + Data.fContentOffsets := CheckContentRect; + All_BorderColor := clGray; + Data.fPSOver.BorderColor:= $404040; + All_GradientStyle := gsFromTopLeft; + end; + if MEnterExit then begin + OnMouseEnter := DoEnter; + OnMouseLeave := DoExit; + end; + OnPaint := DoPaint; + AttachProc(TWindowFunc(@WndProcGRush)); +end; + +function NewGRushButton; +begin + Result := PGRushControl(_NewControl( AParent, 'GRUSH_BUTTON', WS_VISIBLE + or WS_CHILD or WS_TABSTOP, False, @ButtonActions )); + //Result.ClsStyle := Result.ClsStyle or CS_PARENTDC; + Result.Caption := Caption; + Result.fCommandActions.aAutoSzX := 12; + Result.fCommandActions.aAutoSzY := 11; + + + Result.InitLast(TRUE, ctButton); + {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} + Result.AttachProc( WndProcBtnReturnClick ); + {$ENDIF} + Result.OnRecalcRects := TOnRecalcRects(MakeMethod( nil, @DefRecalcRect )); +end; + +function NewGRushPanel; +begin + Result := PGRushControl(_NewControl( AParent, 'GRUSH_PANEL' + , WS_VISIBLE or WS_CHILD, False, @LabelActions )); + + Result.InitLast(FALSE, ctPanel); + Result.All_TextVAlign := vaTop; +end; + +function NewGRushCheckBox; +begin + if CheckRgn = 0 then + CheckRgn := RegionFromArray(_Check); + Result := PGRushControl(_NewControl( AParent, 'GRUSH_CHECKBOX', WS_VISIBLE + or WS_CHILD or WS_TABSTOP, False, @ButtonActions )); + Result.Caption := Caption; + Result.fIgnoreDefault := TRUE; + Result.fCommandActions.aAutoSzX := 24; + + Result.InitLast(TRUE, ctCheckBox); + Result.All_BorderRoundWidth := 0; + Result.All_BorderRoundHeight := 0; +end; + +function NewGRushRadioBox; +begin + if RadioRgn = 0 then + RadioRgn := RegionFromArray(_Radio); + Result := PGRushControl(_NewControl( AParent, 'GRUSH_RADIOBOX', WS_VISIBLE + or WS_CHILD or WS_TABSTOP, False, @ButtonActions )); + Result.fControlClick := ClickGRushRadio; + Result.fCommandActions.aAutoSzX := 24; + Result.Caption := Caption; + Result.fIgnoreDefault := TRUE; + + Result.InitLast(TRUE, ctRadioBox); + Result.All_BorderRoundWidth := 50; + Result.All_BorderRoundHeight := 50; +end; + +function NewGRushSplitter; +var Data: PGRushData; +begin + Result := PGRushControl(NewSplitterEx(AParent, MinSizePrev + , MinSizeNext, esNone)); + Result.InitLast(TRUE, ctSplitter); + Data := PGRushData(Result.CustomObj); + Data.fPSOver.ColorTo := $D0AD95; + Data.fPSDown.ColorTo := $C39475; + {$IFDEF NOT_IMMIDIATLYONLY} + Data.fUpdateSpeed := usVeryFast; + {$ENDIF NOT_IMMIDIATLYONLY} + Data.fSplitterDotsCount := 16; + if (Result.Align in [caLeft, caRight]) then begin + Result.All_GradientStyle := gsHorizontal; + Result.Width := 5; + end else begin + Result.All_GradientStyle := gsVertical; + Result.Height := 5; + end; + Data.fPSDef.GradientStyle := gsSolid; + + Result.All_ColorFrom := clWhite; + Data.fPSDef.ColorFrom := clBtnFace; + Result.All_BorderWidth := 0; + Result.All_BorderRoundWidth := 0; + Result.All_BorderRoundHeight := 0; + Result.Perform(WM_SIZE, 0, 0); +end; + +function NewGRushProgressBar; +var Data: PGRushData; +begin + Result := PGRushControl(_NewControl( AParent, 'GRUSH_PROGRESSBAR' + , WS_VISIBLE or WS_CHILD, False, @LabelActions )); + + Result.InitLast(FALSE, ctProgressBar); + Data := PGRushData(Result.CustomObj); + Data.fDrawProgress := TRUE; + Data.fDrawProgressRect := TRUE; + Result.All_ContentOffsets := ProgressBarContentRect; + Data.fPSDef.ColorTo := $B6977E; + Data.fPSDef.ColorFrom := $E0D2C9; + Result.All_ShadowOffset := 1; + Result.SetAll_ProgressVertical(FALSE); +end; + +function TGRushControl.GetAll_SplDotsOrient: TGRushOrientation; +begin + Result := PGRushData(CustomObj).fSplDotsOrient; +end; + +procedure TGRushControl.SetAll_SplDotsOrient( + const Value: TGRushOrientation); +begin + PGRushData(CustomObj).fSplDotsOrient := Value; + SetAllNeedUpdate; +end; + +initialization + {$IFDEF USE_MMX} + UseMMX := CPUisMMX; + {$ENDIF USE_MMX} + {$IFDEF SYSNEED} + hinst_msimg32 := LoadLibrary( msimg32 ); + {$IFDEF FIX_16BITMODE} + SysGradientFill := GetProcAddress(hinst_msimg32, 'GradientFill'); + {$ENDIF FIX_16BITMODE} + {$IFDEF FIX_DRAWTRANSPARENT} + SysTransparentBlt := GetProcAddress(hinst_msimg32, 'TransparentBlt'); + {$ENDIF FIX_DRAWTRANSPARENT} + if {$IFDEF FIX_16BITMODE}(@SysGradientFill <> nil) and {$ENDIF} + {$IFDEF FIX_DRAWTRANSPARENT}(@SysTransparentBlt <> nil) and {$ENDIF}(WinVer() > wv98) then + UseSystemGradient := TRUE; + {$ENDIF SYSNEED} + +finalization + if CheckRgn <> 0 then + DeleteObject(CheckRgn); + if RadioRgn <> 0 then + DeleteObject(RadioRgn); +end. \ No newline at end of file diff --git a/Addons/KOLGif.pas b/Addons/KOLGif.pas new file mode 100644 index 0000000..fb80900 --- /dev/null +++ b/Addons/KOLGif.pas @@ -0,0 +1,2848 @@ +{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + KKKKK KKKKK OOOOOOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKKKKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL + KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL + + Key Objects Library (C) 2000 by Kladov Vladimir. + + K.O.L. - is a set of objects to create small programs + with Delphi, but without the VCL. It is based on the + idea of XCL, which also allows the creation of smaller + programs then in the VCL (about 5 times smaller). + However, this is not as small as the author (me) would + like. KOL allows the creation of applications about + 10 times smaller then those created with the VCL. But + this does not mean that KOL is less power then the + VCL - perhaps just the opposite... + + XCL and KOL are provided free with the source code. + Idea is copyrighted (C) to me, Vladimir Kladov. + The most of the code is also copyrighted (C) to me. + Code provided by other developers (even if later + changed by me) is fully aknowledged. + + If You wish to take part in developing KOL, please + do let me know. + + mailto: bonanzas@xcl.cjb.net + Home: http://kol.nm.ru + http://xcl.cjb.net + http://xcl.nm.ru + + =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} + +unit KOLGif; +{* This unit contains TGif and TGifDecoder object definitions, implementing + decoding and right painting of Graphic Interchange File format (gif-images). + Encoding is not implemented here. + |
    + This code is ported from XCL code ( XGifs.pas ) with some enchancements. + |
    + Originally, this code was extracted from freeware RXLib Delphi VCL + components library (rxgif.pas). VCL bloats and unneeded dependances + from other parts of RXLib were removed, and important add + was made: exact transparency mask, which helps to correctly + decode and paint ANY gif independantly from current video + settings. + |
    + To get know about authors of RXLib, please visit + |their site. + |
    + Rxgif code, was originally based on source of freeware GBM + program (C++) by + | + Andy Key (nyangau@interalpha.co.uk) + |. +} + +//{$DEFINE CHK_BITBLT} + +interface + +{$I KOLDEF.INC} + +{$IFDEF _D6orHigher} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} + +uses windows, KOL {, ChkGdi}; + +type + TGifVersion = ( gvUnknown, gv87a, gv89a ); + + TGifBits = 1..8; + + TDisposeMethod = ( dmUndefined, dmLeave, dmRestoreBackground, + dmRestorePrevious ); + + TGifColorItem = record + Red: Byte; + Green:Byte; + Blue: Byte; + end; + + TGifColorTable = record + ColorCount : Integer; + Colors : packed array[ Byte ] of TGifColorItem; + end; + + PGifFrame = ^TGifFrame; + + //PGifItem = ^TGifItem; + TGifItem = packed record // object( TObj ) + //private + FImageData : PStream; // memory stream + FSize : TPoint; + FPackedFields : Byte; + FBitsPerPixel : Byte; + FColorMap : TGifColorTable; + {public + destructor Destroy; virtual;} + end; + + //PGifData = ^TGifData; + TGifData = packed record // object( TObj ) + //private + DComment : PStrList; + DAspectRatio : Byte; + DBitsPerPixel : Byte; + DColorResBits : Byte; + DColorMap : TGifColorTable; + {public + constructor Create; + destructor Destroy; virtual;} + end; + + PGifDecoder = ^TGifDecoder; + TGifDecoder = object( TObj ) + {* This object can be used directly to load gif image from file or stream + and to decode its frames. To provide correct drawing of animated gif + images, use TGif object, which is much more power, and works correctly + in the most cases. Therefore, TGifDecoder allows to decode single-frame + images easy and can be used to pack bitmap resources delivered together + with the application. } + private + FGifData : TGifData; + FVersion : TGifVersion; + FItems : PList; // of PGifFrame + FFrameIndex : Integer; + FGifWidth : Integer; + FGifHeight : Integer; + FBkColor : TColor; + FBackIndex : Integer; + FLooping : Boolean; + FRepeatCount : Word; + FNeedMask: Boolean; + FTransparent : Boolean; + FCorrupted: Boolean; + FOnNeedMask: procedure( Sender: PObj; var BIH: TBitmapInfoHeader; Bits: Pointer ); + procedure NewImage; + procedure ClearItems; + function GetFrames(Idx: Integer): PGifFrame; + function GetComment: PStrList; + function GetBitmap: PBitmap; + procedure SetNeedMask(const Value: Boolean); + function GetMask: PBitmap; + protected + function GetWidth : Integer; + function GetHeight: Integer; + function GetFrameCount : Integer; + function GetFrame : Integer; + procedure SetFrame( Value : Integer ); + public + destructor Destroy; virtual; + {* Use Free method instead. } + procedure Clear; + {* Clears gif image. } + property Count : Integer read GetFrameCount; + {* Returns count of frames stored in the gif image. } + property Frame : Integer read GetFrame write SetFrame; + {* Index of current frame (between 0 and Count-1). } + property Width : Integer read GetWidth; + {* Width of entire gif image. } + property Height : Integer read GetHeight; + {* Height of entire gif image. } + property BkColor : TColor read FBkColor write FBkColor; + {* Background color. After loading gif, this property contains a value, + which is used as a background (e.g. transparent) color of the entire + set of frames. For non-transparent images, this value is set to + clNone after loading the image. It is possible to change this value, + but this will affect only the Draw method (if TGifDecoder object is + used in TGif container). DrawTransp and DrawTransparent methods (of + TGif, too) use BkColor only for non-transparent images, and in case when + NeedMask is reset to False. } + property Looping: Boolean read FLooping write FLooping; + {* True, if loaded image is marked (by its authors) as "looping". } + property RepeatCount : Word read FRepeatCount write FRepeatCount; + {* Repeat count set by the author of gif image. } + property NeedMask : Boolean read FNeedMask write SetNeedMask; + {* This value is False by default for TGifDecoder instances used stanalone, + but it is set to True, when TGif is using the owned TGifDecoder object. + True requires a bit larger code to implement really truth transparency, + which independs from display resolution and color depth, and works + correctly even in case when background color of the first frame matches + non-transparent colors of other ones. } + property Transparent : Boolean read FTransparent; + {* True, if loaded gif image is transparent. } + property Version : TGifVersion read FVersion; + {* Version of gif. } + property Frames[ Idx : Integer ] : PGifFrame read GetFrames; + {* Acess frames as an array of pointers to TGifFrame object instances, + created while gif image is loading. } + property Comment : PStrList read GetComment; + {* Text comment, provided with gif image. } + function LoadFromStream( Stream : PStream ) : Boolean; + {* Call this method to load gif image from a stream and decode it. After + loading, first frame is decoded and ready to be drawn immediately. All + other frames are decoded when requested first time. Since this, a property + Corrupted can be not set to True just after loading the image and decoding + several first frames, and can become True later, when requested frame + found corrupted while decoding it. } + function LoadFromFile( const FileName : String ) : Boolean; + {* Call this method to load gif image from the file and decode it. See + also LoadFromStream - the most told there is true here too. } + function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean; + {* Call this method to load GIF image from resource by its name. + GIF image must be stored in RCDATA resource named using unique + ANSI string. } + function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; + {* Call this method to load GIF from resource (RCDATA) by ID. } + property Bitmap : PBitmap read GetBitmap; + {* Current frame bitmap. } + property Mask: PBitmap read GetMask; + {* Current frame truth mask. } + procedure FreeResources; + {* Call this method to free the most of GDI resources allocated while + decoding the image. This forces using DIB bitmaps without handles + (see TBitmap.Dormant), releases Canvas, Brush objects etc. } + property Corrupted: Boolean read FCorrupted; + {* True, if the image found corrupted while decoding. Note, that just after + loading the image and after decoding several first frames, this property + can be yet not set even for bad gifs. It becomes True for such gif images + when a frame requested is corrupted. } + end; + + TGifFrame = object( TObj ) + {* Object to manipulate with certain frame data of TGIF object. } + private + FOwner : PGifDecoder; + FBitmap : PBitmap; + FItem : TGifItem; + FExtensions : PList; + FTopLeft : TPoint; + FInterlaced : Boolean; + FCorrupted : Boolean; + FTranspColor : TColor; + FDelay : Word; + FLocalColors : Boolean; + FTransparent : Boolean; + FTransIndex : Integer; + FTransMask : PBitmap; + FFrameIndex : Integer; + FReallyTransparent : Boolean; + FDisposalMethod: TDisposeMethod; + procedure SetDelay(const Value: Word); + function GetColorCount: Integer; + function FindComment(ForceCreate: Boolean): PStrList; + function GetComment: PStrList; + procedure SetComment(const Value: PStrList); + procedure SetDisposalMethod(const Value: TDisposeMethod); + procedure SetTranspColor(const Value: TColor); + procedure SetTopLeft(const Value: TPoint); + function GetHeight: Integer; + function GetWidth: Integer; + function GetReallyTransparent: Boolean; + function GetBitmap: PBitmap; + procedure New_Bitmap; + protected + //constructor Create( AOwner : PGifDecoder ); + function LoadFromStream( Stream : PStream ) : Boolean; + public + destructor Destroy; virtual; + {* Do not destroy frames manually. The owner of frames (TGifDecoder) is + responsible for freeing its frames. } + property Bitmap : PBitmap read GetBitmap; + {* Frame bitmap. This can be only a small rectangle in bounds of + entire GIF image. If You do not know how to combine frame + bitmaps to produce GIF animation, use TGIF drawing methods + to perform this task. } + property Mask : PBitmap read FTransMask; + {* Exact monochrome mask of transparency. Used in ZGIF drawing + to produce correct showing of any GIF image independently + from display resolution. } + property Delay : Word read FDelay write SetDelay; + {* Frame delay (delay of frame exposure). } + property ColorCount : Integer read GetColorCount; + {* Number of colors. } + property Comment: PStrList read GetComment write SetComment; + {* Comment to frame. } + property DisposalMethod : TDisposeMethod read FDisposalMethod write SetDisposalMethod; + {* Disposal method. This is the most hard part for recognition + how to animate certain GIF image. It seems that it is implemented + in TGIF well, at least, it was tested for about 200 different + GIF clips, and no errors were found. } + property Interlaced: Boolean read FInterlaced; + {* True, if interlaced. } + property Corrupted: Boolean read FCorrupted; + {* True, if corrupted. } + property TranspColor : TColor read FTranspColor write SetTranspColor; + {* Transparent color. } + property Origin: TPoint read FTopLeft write SetTopLeft; + {* Offset of a frame from top left corner of GIF image. } + property Width: Integer read GetWidth; + {* Width of frame. } + property Height: Integer read GetHeight; + {* Height of frame. } + property Transparent : Boolean read FTransparent; + {* True, if frame is transparent. } + property TransColorIndex : Integer read fTransIndex; + {* Exact index of transparent color in frame's palette. } + property ReallyTransparent : Boolean read GetReallyTransparent; + {* True, if frame is "really" transparent (i.e. its transparent + color is used in frame at least for one pixel). } + procedure FreeResources; + {* } + procedure Draw( DC : HDC; X, Y : Integer ); + {* } + procedure StretchDraw( DC : HDC; Rect : TRect ); + {* } + end; + +///////////////////////////////////////////////////////////// + PGif = ^TGif; + TGif = object( TObj ) + {* GIF decoding and painting object. This object represents almost full + decoder, which yet not a control but already sufficiently "clever" + to treat "frame" as a result of all previous frame commands. I.e. + You do not need to combine frames by yourself to provide animation. + Just change current frame index (usually increase) and call one of + drawing methods to paint the desired frame. } + private + FGifImage : PGifDecoder; + FCurFrame : PBitmap; + FCurMask : PBitmap; + FCurIndex : Integer; + FPrevFrame : PBitmap; + FPrevMask : PBitmap; + procedure PrepareFrame; + function GetBkColor: TColor; + procedure SetBkColor(const Value: TColor); + function GetFrames(Idx: Integer): PGifFrame; + function GetTransparent: Boolean; + function GetCorrupted: Boolean; + protected + FOnChanged: TOnEvent; + function GetWidth : Integer; + procedure SetWidth( Value : Integer ); + function GetHeight : Integer; + procedure SetHeight( Value : Integer ); + function GetFrame : Integer; + procedure SetFrame( Value : Integer ); + function GetFrameCount : Integer; + function GetDelays( Idx : Integer ) : Integer; + procedure SetDelays( Idx : Integer; Value : Integer ); + procedure Changed; + public + destructor Destroy; virtual; + {* Destructor. } + procedure Clear; + {* Obvious. } + property Width: Integer read GetWidth write SetWidth; + {* Width of total GIF image. } + property Height: Integer read GetHeight write SetHeight; + {* Height of total GIF image. } + procedure FreeResources; + {* Call this method to free GDI resources, allocated for decoding gif image, + and to drawing it. This does not destroy any image information or data + already obtained from encoded frames. It is possible to call this method + after drawing every other frame, but this can slow down drawing process + a bit. } + procedure Draw( DC : HDC; X, Y : Integer ); + {* Draws current frame. } + procedure DrawTransp( DC: HDC; X, Y: Integer ); + {* Draws current frame transparently, using its native TranspColor as + transparent color if any. If the frame is not transparent, it is + drawing non-transparently. } + procedure DrawTransparent( DC : HDC; X, Y : Integer; TranspColor : TColor ); + {* Draws current frame transparently. } + // By Dufa + procedure DrawTransparentEx(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer); + // Draw Tranparent Frame + procedure StretchDraw( DC : HDC; const Dest : TRect ); //override; + {* Draws current frame with stretching. } + procedure StretchDrawTransp( DC: HDC; const Dest: TRect ); + {* Draws current frame stretched and transparently using BkColor as a + transparent color or using Mask if available. } + procedure StretchDrawTransparent( DC : HDC; const Dest : TRect; TranspColor : TColor ); + {* Draws current frame with strethcing transparently. } + property BkColor : TColor read GetBkColor write SetBkColor; + {* Background color. } + property Frames[ Idx : Integer ] : PGifFrame read GetFrames; + {* Array of frame data. } + property Transparent : Boolean read GetTransparent; + {* True, if GIF is transparent (i.e. at least one of frames is transparent). } + function LoadFromStream( Stream : PStream ) : Boolean; + {* Loads GIF from a stream. } + function LoadFromFile( const FileName : String ) : Boolean; + {* Loads GIF from a file. } + function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean; + {* Call this method to load GIF image from resource by its name. + GIF image must be stored in RCDATA resource named using unique + ANSI string. } + function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; + {* Call this method to load GIF from resource (RCDATA) by ID. } + property Count: Integer read GetFrameCount; + {* Number of frames in a gif. } + property Frame: Integer read GetFrame write SetFrame; + {* Index of current frame. } + property Delay[ Idx: Integer ]: Integer read GetDelays write SetDelays; + {* Delay for every frame. } + property Corrupted: Boolean read GetCorrupted; + {* True if any of frames decoded is corrupted or could not be decoded. } + end; + +function NewGif: PGif; +{* Call this function to create fully featured gif decoding and painting object. + This adds about 30K code to the executable. } +function NewGifNoMask: PGif; +{* Call this method to create gif decoding object, which does not support for + truth mask (some animated and / or transparent images are drawn incorrectly, + but code used is smaller a bit). Actually, this economies only about 1K of code. } +function NewGifDecoder: PGifDecoder; +{* Call this method to create simple gif reading object, which just decodes + separate frames. If only this type of objects is used, smaller portion of + code is included into final executeable. Actually, this economies about 5-6K + of executable size. } + +procedure DrawBitmapMaskMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap ); +procedure DrawBitmapMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap ); + +type + PGifShow = ^TGifShow; + TGifShow = object( TControl ) + private + function GetDummy: Boolean; + protected + function GetAnimate: Boolean; + function GetGif: PGif; + procedure SetAnimate(const Value: Boolean); + function GetLoop: Boolean; + function GetOnEndLoop: TOnEvent; + procedure SetLoop(const Value: Boolean); + procedure SetOnEndLoop(const Value: TOnEvent); + function GetAutosize: Boolean; + function GetStretch: Boolean; + procedure SetAutosize(const Value: Boolean); + procedure SetStretch(const Value: Boolean); + protected + procedure GifChanged( Sender: PObj ); + procedure NextFrame( Sender: PObj ); + procedure PaintFrame( Sender: PControl; DC: HDC ); + public + {$WARNINGS OFF} + property Autosize: Boolean read GetAutosize write SetAutosize; + {$WARNINGS ON} + property Stretch: Boolean read GetStretch write SetStretch; + property Animate: Boolean read GetAnimate write SetAnimate; + property Loop: Boolean read GetLoop write SetLoop; + //property Dormant: Boolean read GetDormant write SetDormant; + property Gif: PGif read GetGif; + property OnEndLoop: TOnEvent read GetOnEndLoop write SetOnEndLoop; + property OnPaint: Boolean read GetDummy; + function LoadFromStream( Stream : PStream ) : Boolean; + {* Call this method to load gif image from a stream and decode it. After + loading, first frame is decoded and ready to be drawn immediately. All + other frames are decoded when requested first time. Since this, a property + Corrupted can be not set to True just after loading the image and decoding + several first frames, and can become True later, when requested frame + found corrupted while decoding it. } + function LoadFromFile( const FileName : String ) : Boolean; + {* Call this method to load gif image from the file and decode it. See + also LoadFromStream - the most told there is true here too. } + function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean; + {* Call this method to load GIF image from resource by its name. + GIF image must be stored in RCDATA resource named using unique + ANSI string. } + function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; + {* Call this method to load GIF from resource (RCDATA) by ID. } + end; + +function NewGifShow( AParent: PControl ): PGifShow; + +type TKOLGifShow = PGifShow; + +implementation + +const + ROP_DstAndNotSrc = $00220326; + +function NewGifFrame( AOwner: PGifDecoder ): PGifFrame; forward; + +procedure DrawBitmapMaskMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap ); +begin + if Msk = nil then + Bmp.Draw( DC, X, Y ) + else + //if Bmp.HandleAllocated then + begin + BitBlt( DC, X, Y, Bmp.Width, Bmp.Height, Msk.Canvas.Handle, + 0, 0, SrcAnd ); + {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} + BitBlt( DC, X, Y, Bmp.Width, Bmp.Height, + Bmp.Canvas.Handle, 0, 0, SRCPAINT ); + {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} + end; +end; +procedure DrawBitmapMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap ); +var TmpBmp : PBitmap; +begin + if Msk = nil then + Bmp.Draw( DC, X, Y ) + else + //if Bmp.HandleAllocated then + begin + TmpBmp := NewBitmap( 0, 0 ); + TmpBmp.Assign( Bmp ); + BitBlt( TmpBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, + Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc ); + {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} + DrawBitmapMaskMask( DC, X, Y, TmpBmp, Msk ); + //TmpBmp.SaveToFile( GetStartDir + 'DrawBitmapMask.TmpBmp.bmp' ); + //Msk.SaveToFile( GetStartDir + 'DrawBitmapMask.Msk.bmp' ); + TmpBmp.Free; + end; +end; + +procedure StretchBitmapMaskMask( DC : HDC; Rect : TRect; Bmp, Msk : PBitmap ); +var OldMode: Integer; + OldOrgX: TPoint; +begin + OldMode := SetStretchBltMode( DC, HALFTONE ); + SetBrushOrgEx( DC, 0, 0, @ OldOrgX ); + if Msk = nil then + Bmp.StretchDraw( DC, Rect ) + else + //if Bmp.HandleAllocated then + begin + StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, + Msk.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, SrcAnd ); + StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, + Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, SRCPAINT ); + end; + SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil ); + SetStretchBltMode( DC, OldMode ); +end; + +procedure StretchBitmapMask( DC : HDC; Rect : TRect; Bmp, Msk : PBitmap ); +var TmpBmp : PBitmap; + OldMode: Integer; + OldOrgX: TPoint; +begin + OldMode := SetStretchBltMode( DC, HALFTONE ); + SetBrushOrgEx( DC, 0, 0, @ OldOrgX ); + if Msk = nil then + Bmp.StretchDraw( DC, Rect ) + else + //if Bmp.HandleAllocated then + begin + //TmpBmp := NewDIBBitmap( 0, 0, Bmp.PixelFormat ); + TmpBmp := NewBitmap( 0, 0 ); + TmpBmp.Assign( Bmp ); + BitBlt( TmpBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, + Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc ); + {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} + StretchBitmapMaskMask( DC, Rect, TmpBmp, Msk ); + TmpBmp.Free; + end; + SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil ); + SetStretchBltMode( DC, OldMode ); +end; + +{function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer; +begin + Result := PChar(HugePtr) + Amount; +end;} + +function AllocMemo(Size: Longint): Pointer; +begin + if Size > 0 then + Result := GlobalAllocPtr(HeapAllocFlags or GMEM_ZEROINIT, Size) + else Result := nil; +end; + +procedure FreeMemo(var fpBlock: Pointer); +begin + if fpBlock <> nil then begin + GlobalFreePtr(fpBlock); + fpBlock := nil; + end; +end; + +const + GIFSignature = 'GIF'; + GIFVersionStr: array[TGIFVersion] of PChar = (#0#0#0, '87a', '89a'); + +const + CODE_TABLE_SIZE = 4096; + HASH_TABLE_SIZE = 17777; + MAX_LOOP_COUNT = 30000; + + CHR_EXT_INTRODUCER = '!'; + CHR_IMAGE_SEPARATOR = ','; + CHR_TRAILER = ';'; { indicates the end of the GIF Data stream } + +{ Image descriptor bit masks } + + ID_LOCAL_COLOR_TABLE = $80; { set if a local color table follows } + ID_INTERLACED = $40; { set if image is interlaced } + ID_SORT = $20; { set if color table is sorted } + ID_RESERVED = $0C; { reserved - must be set to $00 } + ID_COLOR_TABLE_SIZE = $07; { Size of color table as above } + +{ Logical screen descriptor packed field masks } + + LSD_GLOBAL_COLOR_TABLE = $80; { set if global color table follows L.S.D. } + LSD_COLOR_RESOLUTION = $70; { Color resolution - 3 bits } + LSD_SORT = $08; { set if global color table is sorted - 1 bit } + LSD_COLOR_TABLE_SIZE = $07; { Size of global color table - 3 bits } + { Actual Size = 2^value+1 - value is 3 bits } + +{ Graphic control extension packed field masks } + + GCE_TRANSPARENT = $01; { whether a transparency Index is given } + GCE_USER_INPUT = $02; { whether or not user input is expected } + GCE_DISPOSAL_METHOD = $1C; { the way in which the graphic is to be treated after being displayed } + GCE_RESERVED = $E0; { reserved - must be set to $00 } + +{ Application extension } + + AE_LOOPING = $01; { looping Netscape extension } + + GIFColors: array[TGIFBits] of Word = (2, 4, 8, 16, 32, 64, 128, 256); + +function ColorsToBits(ColorCount: Word): Byte; +var + I: TGIFBits; +begin + for I := Low(TGIFBits) to High(TGIFBits) do + if ColorCount = GIFColors[I] then + begin + Result := I; + Exit; + end; + Result := 0; +end; + +{function ColorsToPixelFormat(Colors: Word): TPixelFormat; +begin + //if Colors <= 2 then Result := pf1bit + //else if Colors <= 16 then Result := pf4bit + //else if Colors <= 256 then Result := pf8bit + //else Result := pf24bit; + //else + Result := pf16bit; //&&& +end;} + +function ItemToRGB(const Item: TGIFColorItem): Longint; +begin + with Item do + Result := RGB(Red, Green, Blue); +end; + +{ The following types and function declarations are used to call into + functions of the GIF implementation of the GIF image + compression/decompression standard. } + +type + TGIFHeader = packed record + Signature: array[0..2] of Char; { contains 'GIF' } + Version: array[0..2] of Char; { '87a' or '89a' } + end; + + TScreenDescriptor = packed record + ScreenWidth: Word; { logical screen width } + ScreenHeight: Word; { logical screen height } + PackedFields: Byte; + BackgroundColorIndex: Byte; { Index to global color table } + AspectRatio: Byte; { actual ratio = (AspectRatio + 15) / 64 } + end; + + TImageDescriptor = packed record + ImageLeftPos: Word; { column in pixels in respect to left of logical screen } + ImageTopPos: Word; { row in pixels in respect to top of logical screen } + ImageWidth: Word; { width of image in pixels } + ImageHeight: Word; { height of image in pixels } + PackedFields: Byte; + end; + +{ GIF Extensions support } + +type + TExtensionType = (etGraphic, etPlainText, etApplication, etComment); + +const + ExtLabels: array[TExtensionType] of Byte = ($F9, $01, $FF, $FE); + LoopExt: string[11] = 'NETSCAPE2.0'; + +type + TGraphicControlExtension = packed record + BlockSize: Byte; { should be 4 } + PackedFields: Byte; + DelayTime: Word; { in centiseconds } + TransparentColorIndex: Byte; + Terminator: Byte; + end; + + TPlainTextExtension = packed record + BlockSize: Byte; { should be 12 } + Left, Top, Width, Height: Word; + CellWidth, CellHeight: Byte; + FGColorIndex, BGColorIndex: Byte; + end; + + TAppExtension = packed record + BlockSize: Byte; { should be 11 } + AppId: array[1..8] of Byte; + Authentication: array[1..3] of Byte; + end; + + TExtensionRecord = packed record + case ExtensionType: TExtensionType of + etGraphic: (GCE: TGraphicControlExtension); + etPlainText: (PTE: TPlainTextExtension); + etApplication: (APPE: TAppExtension); + end; + +type + PExtension = ^TExtension; + TExtension = object( TObj ) + private + FExtType: TExtensionType; + FList: PStrList; + FExtRec: TExtensionRecord; + public + function IsLoopExtension: Boolean; + destructor Destroy; virtual; + end; + +destructor TExtension.Destroy; +begin + FList.Free; + inherited; +end; + +function TExtension.IsLoopExtension: Boolean; +begin + Result := (FExtType = etApplication) and CompareMem(@FExtRec.APPE.AppId, + @LoopExt[1], FExtRec.APPE.BlockSize) and (FList.Count > 0) and + (Length(FList.Items[0]) >= 3) and (Byte(FList.Items[0][1]) = AE_LOOPING); +end; + +function FindExtension(Extensions: PList; ExtType: TExtensionType): PExtension; +var + I: Integer; +begin + if Extensions <> nil then + for I := Extensions.Count - 1 downto 0 do begin + Result := PExtension(Extensions.Items[I]); + if (Result <> nil) and (Result.FExtType = ExtType) then Exit; + end; + Result := nil; +end; + +procedure FreeExtensions(Extensions: PList); +begin + if Extensions <> nil then + begin + while Extensions.Count > 0 do + begin + PObj(Extensions.Items[Extensions.Count - 1]).Free; + Extensions.Delete(Extensions.Count - 1); + end; + Extensions.Free; + end; +end; + +{ GIF read procedures + + Procedures to read and write GIF files, GIF-decoding and encoding + based on freeware C source code of GBM package by Andy Key + (nyangau@interalpha.co.uk). The home page of GBM author is + at http://www.interalpha.net/customer/nyangau/. } + +type + PIntCodeTable = ^TIntCodeTable; + TIntCodeTable = array[0..CODE_TABLE_SIZE - 1] of Word; + + PReadContext = ^TReadContext; + TReadContext = record + Inx, Size: Longint; + Buf: array[0..255 + 4] of Byte; + CodeSize: Longint; + ReadMask: Longint; + end; + + TOutputContext = record + W, H, X, Y: Longint; + BitsPerPixel, Pass: Integer; + Interlace: Boolean; + LineIdent: Longint; + Data, CurrLineData: Pointer; + end; + + PImageDict = ^TImageDict; + TImageDict = record + Tail, Index: Word; + Col: Byte; + end; + + PDictTable = ^TDictTable; + TDictTable = array[0..CODE_TABLE_SIZE - 1] of TImageDict; + + PRGBPalette = ^TRGBPalette; + TRGBPalette = array [Byte] of TRGBQuad; + +function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; +begin + Result := Y; + case Pass of + 0, 1: Inc(Result, 8); + 2: Inc(Result, 4); + 3: Inc(Result, 2); + end; + if Result >= Height then begin + if Pass = 0 then begin + Pass := 1; Result := 4; + if (Result < Height) then Exit; + end; + if Pass = 1 then begin + Pass := 2; Result := 2; + if (Result < Height) then Exit; + end; + if Pass = 2 then begin + Pass := 3; Result := 1; + end; + end; +end; + +procedure ReadImageStream(Stream : PStream; Dest: PStream; var Desc: TImageDescriptor; + var Interlaced, LocalColors, Corrupted: Boolean; var BitsPerPixel: Byte; + var ColorTable: TGIFColorTable); +const BufSize = 1024; +var + CodeSize, BlockSize: Byte; + + procedure ProvideDestSize( Size : DWord ); + begin + if Dest.Size < Size then + Dest.Size := Size; + end; +begin + Corrupted := False; + Stream.Read(Desc, SizeOf(TImageDescriptor)); + Interlaced := (Desc.PackedFields and ID_INTERLACED) <> 0; + if (Desc.PackedFields and ID_LOCAL_COLOR_TABLE) <> 0 then + begin + { Local colors table follows } + BitsPerPixel := 1 + Desc.PackedFields and ID_COLOR_TABLE_SIZE; + LocalColors := True; + ColorTable.ColorCount := 1 shl BitsPerPixel; + Stream.Read(ColorTable.Colors[0], + ColorTable.ColorCount * SizeOf(TGIFColorItem)); + end + else + begin + LocalColors := False; + FillChar(ColorTable, SizeOf(ColorTable), 0); + end; + Stream.Read(CodeSize, 1); + ProvideDestSize( BufSize ); + Dest.Write(CodeSize, 1); + repeat + Stream.Read(BlockSize, 1); + if (Stream.Position + BlockSize) > Stream.Size then + begin + Corrupted := True; + Exit; {!!?} + end; + ProvideDestSize( ((Dest.Size + 1 + BlockSize + BufSize - 1) div BufSize) * BufSize ); + Dest.Write(BlockSize, 1); + if (Stream.Position + BlockSize) > Stream.Size then + begin + BlockSize := Stream.Size - Stream.Position; + Corrupted := True; + end; + if BlockSize > 0 then + Stream2Stream( Dest, Stream, BlockSize ); + until (BlockSize = 0) or (Stream.Position >= Stream.Size); +end; + +procedure FillRGBPalette(const ColorTable: TGIFColorTable; + var Colors: TRGBPalette); +var + I: Byte; +begin + FillChar(Colors, SizeOf(Colors), $80); + for I := 0 to ColorTable.ColorCount - 1 do begin + Colors[I].rgbRed := ColorTable.Colors[I].Red; + Colors[I].rgbGreen := ColorTable.Colors[I].Green; + Colors[I].rgbBlue := ColorTable.Colors[I].Blue; + Colors[I].rgbReserved := 0; + end; +end; + +function ReadCode(Stream: PStream; var Context: TReadContext): Longint; +var + RawCode: Longint; + ByteIndex: Longint; + Bytes: Byte; + BytesToLose: Longint; +begin + while (Context.Inx + Context.CodeSize > Context.Size) and + (Stream.Position < Stream.Size) do + begin + { not enough bits in buffer - refill it } + { Not very efficient, but infrequently called } + BytesToLose := Context.Inx shr 3; + { Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes } + Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3); + Context.Inx := Context.Inx and 7; + Context.Size := Context.Size - (BytesToLose shl 3); + Stream.Read(Bytes, 1); + if Bytes > 0 then + Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes); + Context.Size := Context.Size + (Bytes shl 3); + end; + ByteIndex := Context.Inx shr 3; + RawCode := Context.Buf[Word(ByteIndex)] + + (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); + if Context.CodeSize > 8 then + RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16); + RawCode := RawCode shr (Context.Inx and 7); + Context.Inx := Context.Inx + Byte(Context.CodeSize); + Result := RawCode and Context.ReadMask; +end; + +procedure Output(Value: Byte; var Context: TOutputContext); +var + P: PByte; +begin + if (Context.Y >= Context.H) then Exit; + case Context.BitsPerPixel of + 1: begin + //P := HugeOffset(Context.CurrLineData, Context.X shr 3); + P := Pointer( Integer( Context.CurrLineData ) + Context.X shr 3 ); + if (Context.X and $07 <> 0) then + P^ := P^ or Word(value shl (7 - (Word(Context.X and 7)))) + else P^ := Byte(value shl 7); + end; + 4: begin + //P := HugeOffset(Context.CurrLineData, Context.X shr 1); + P := Pointer( Integer( Context.CurrLineData ) + Context.X shr 1 ); + if (Context.X and 1 <> 0) then P^ := P^ or Value + else P^ := Byte(value shl 4); + end; + 8: begin + //P := HugeOffset(Context.CurrLineData, Context.X); + P := Pointer( Integer( Context.CurrLineData ) + Context.X ); + P^ := Value; + end; + end; + Inc(Context.X); + if Context.X < Context.W then Exit; + Context.X := 0; + if Context.Interlace then + Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass) + else Inc(Context.Y); + Context.CurrLineData := //HugeOffset(Context.Data, + //(Context.H - 1 - Context.Y) * Context.LineIdent); + Pointer( Integer( Context.Data ) + (Context.H - 1 - Context.Y) * Context.LineIdent ); +end; + + +procedure ReadGIFData(Stream: PStream; const Header: TBitmapInfoHeader; + Interlaced: Boolean; IntBitPerPixel: Byte; Data: Pointer; + var Corrupted: Boolean); +var + MinCodeSize: Byte; + MaxCode, BitMask, InitCodeSize: Longint; + ClearCode, EndingCode, FirstFreeCode, FreeCode: Word; + I, OutCount, Code: Longint; + CurCode, OldCode, InCode, FinalChar: Word; + Prefix, Suffix, OutCode: PIntCodeTable; + ReadCtxt: TReadContext; + OutCtxt: TOutputContext; + TableFull: Boolean; +begin + Corrupted := False; + OutCount := 0; OldCode := 0; FinalChar := 0; + TableFull := False; + Prefix := AllocMem(SizeOf(TIntCodeTable)); + //try + Suffix := AllocMem(SizeOf(TIntCodeTable)); + //try + OutCode := AllocMem(SizeOf(TIntCodeTable) + SizeOf(Word)); + //try + //try + Stream.Read(MinCodeSize, 1); + if (MinCodeSize < 2) or (MinCodeSize > 9) then + begin + //GifError( 'Bad GIF Code Size' ); + Corrupted := True; + Exit; + end; + { Initial read context } + ReadCtxt.Inx := 0; + ReadCtxt.Size := 0; + ReadCtxt.CodeSize := MinCodeSize + 1; + ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; + { Initialise pixel-output context } + OutCtxt.X := 0; OutCtxt.Y := 0; + OutCtxt.Pass := 0; + OutCtxt.W := Header.biWidth; + OutCtxt.H := Header.biHeight; + OutCtxt.BitsPerPixel := Header.biBitCount; + OutCtxt.Interlace := Interlaced; + OutCtxt.LineIdent := ((Header.biWidth * Header.biBitCount + 31) + div 32) * 4; + OutCtxt.Data := Data; + //OutCtxt.CurrLineData := HugeOffset(Data, (Header.biHeight - 1) * + // OutCtxt.LineIdent); + OutCtxt.CurrLineData := Pointer( Integer( Data ) + (Header.biHeight - 1) * + OutCtxt.LineIdent ); + BitMask := (1 shl IntBitPerPixel) - 1; + { 2 ^ MinCodeSize accounts for all colours in file } + ClearCode := 1 shl MinCodeSize; + EndingCode := ClearCode + 1; + FreeCode := ClearCode + 2; + FirstFreeCode := FreeCode; + { 2^ (MinCodeSize + 1) includes clear and eoi Code and space too } + InitCodeSize := ReadCtxt.CodeSize; + MaxCode := 1 shl ReadCtxt.CodeSize; + Code := ReadCode(Stream, ReadCtxt); + while (Code <> EndingCode) and (Code <> $FFFF) and + (OutCtxt.Y < OutCtxt.H) do + begin + if (Code = ClearCode) then begin + ReadCtxt.CodeSize := InitCodeSize; + MaxCode := 1 shl ReadCtxt.CodeSize; + ReadCtxt.ReadMask := MaxCode - 1; + FreeCode := FirstFreeCode; + Code := ReadCode(Stream, ReadCtxt); + CurCode := Code; OldCode := Code; + if (Code = $FFFF) then Break; + FinalChar := (CurCode and BitMask); + Output(Byte(FinalChar), OutCtxt); + TableFull := False; + end + else + begin + CurCode := Code; + InCode := Code; + if CurCode >= FreeCode then begin + CurCode := OldCode; + OutCode^[OutCount] := FinalChar; + Inc(OutCount); + end; + while (CurCode > BitMask) do + begin + if (OutCount > CODE_TABLE_SIZE) then + begin + //if LoadCorrupt then + //begin + CurCode := BitMask; + OutCount := 1; + Corrupted := True; + Break; + {end + else //GifError( 'GIF Decode Error' ); + begin + Corrupted := True; + Break; + end;} + end; + OutCode^[OutCount] := Suffix^[CurCode]; + Inc(OutCount); + CurCode := Prefix^[CurCode]; + end; + if Corrupted then Break; + FinalChar := CurCode and BitMask; + OutCode^[OutCount] := FinalChar; + Inc(OutCount); + for I := OutCount - 1 downto 0 do + Output(Byte(OutCode^[I]), OutCtxt); + OutCount := 0; + { Update dictionary } + if not TableFull then begin + Prefix^[FreeCode] := OldCode; + Suffix^[FreeCode] := FinalChar; + { Advance to next free slot } + Inc(FreeCode); + if (FreeCode >= MaxCode) then begin + if (ReadCtxt.CodeSize < 12) then begin + Inc(ReadCtxt.CodeSize); + MaxCode := MaxCode shl 1; + ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; + end + else TableFull := True; + end; + end; + OldCode := InCode; + end; + Code := ReadCode(Stream, ReadCtxt); + end; { while } + if Code = $FFFF then //GifError('Read GIF Error'); + begin + Corrupted := True; + //Break; + end; + //finally + //end; + //finally + FreeMem( OutCode {, SizeOf(TIntCodeTable) + SizeOf(Word)} ); + //end; + //finally + FreeMem(Suffix {, SizeOf(TIntCodeTable)} ); + //end; + //finally + FreeMem(Prefix {, SizeOf(TIntCodeTable)} ); + //end; +end; + +{ TGifFrame } + +function NewGifFrame(AOwner: PGifDecoder): PGifFrame; +begin + new( Result, Create ); + Result.FOwner := AOwner; + Result.FTransIndex := -1; + Result.FItem.FImageData := NewMemoryStream; + Result.FTranspColor := clNone; +end; + +destructor TGifFrame.Destroy; +begin + FBitmap.Free; + FTransMask.Free; + FItem.FImageData.Free; + FreeExtensions( FExtensions ); + inherited; +end; + +procedure TGifFrame.Draw(DC : HDC; X, Y: Integer); +begin + GetBitmap; // create Mask if it is needed + + if Mask = nil then + FBitmap.Draw( DC, X, Y ) + else + DrawBitmapMask( DC, X, Y, FBitmap, FTransMask ); +end; + +function TGifFrame.FindComment(ForceCreate: Boolean): PStrList; +var + Ext: PExtension; +begin + Ext := FindExtension(FExtensions, etComment); + if (Ext = nil) and ForceCreate then + begin + new( Ext, Create ); + Ext.FExtType := etComment; + if FExtensions = nil then FExtensions := NewList; + FExtensions.Add(Ext); + end; + if (Ext <> nil) then + begin + if (Ext.FList = nil) and ForceCreate then + Ext.FList := NewStrList; + Result := Ext.FList; + end + else Result := nil; +end; + +procedure TGifFrame.FreeResources; +begin + if FBitmap <> nil then + FBitmap.Dormant; + if FTransMask <> nil then + FTransMask.Dormant; +end; + +{procedure SnapStream2File( Strm: PStream; const Fname: String ); +var PP: Integer; + FS: PStream; +begin + PP := Strm.Position; + Strm.Position := 0; + FS := NewWriteFileStream( Fname ); + Stream2Stream( FS, Strm, Strm.Size ); + FS.Free; + Strm.Position := PP; +end;} + +function FillMaskLine4( Mask, Scan : PByte; W : Integer; TransIdx : Integer ) + : Boolean; +assembler; +asm + PUSH ESI + PUSH EDI + PUSH EBX + MOV EDI, EAX + MOV ESI, EDX + MOV EDX, TransIdx + MOV DH, 0 + INC ECX + SHR ECX, 1 + JZ @@fin + MOV BX, 8000h + CLD +@@loop1: + LODSB + MOV AH, AL + SHR AH, 4 + CMP AH, DL + JNZ @@1 + OR BL, BH + MOV DH, BL +@@1: ROR BH, 1 + AND AL, 0Fh + CMP AL, DL + JNZ @@2 + OR BL, BH + MOV DH, BL +@@2: ROR BH, 1 + JNC @@e_loop + MOV [EDI], BL + INC EDI + MOV BL, 0 +@@e_loop: + LOOP @@loop1 + CMP BH, 80h + JZ @@fin + MOV [EDI], BL + +@@fin: + XOR EAX, EAX + MOV AL, DH + POP EBX + POP EDI + POP ESI +end; + +{function FillMaskLine8( Mask, Scan : PByte; W : Integer; TransIdx : Integer ) + : Boolean; +assembler; +asm + PUSH ESI + PUSH EDI + PUSH EBX + MOV EDI, EAX + MOV ESI, EDX + MOV EDX, TransIdx + MOV DH, 0 + JECXZ @@fin + MOV BX, 8000h + CLD +@@loop1: + LODSB + CMP AL, DL + JNZ @@2 + OR BL, BH + MOV DH, BL +@@2: ROR BH, 1 + JNC @@e_loop + MOV [EDI], BL + INC EDI + MOV BL, 0 +@@e_loop: + LOOP @@loop1 + CMP BH, 80h + JZ @@fin + MOV [EDI], BL + +@@fin: + XOR EAX, EAX + MOV AL, DH + POP EBX + POP EDI + POP ESI +end; + +function FillMaskLine0( Mask, Scan : PByte; W : Integer ) + : Boolean; +assembler; +asm + PUSH ESI + PUSH EDI + MOV EDI, EAX + MOV ESI, EDX + MOV EDX, 0 + ADD ECX, 7 + SHR ECX, 3 + JZ @@fin + CLD +@@loop1: + LODSB + NOT AL + STOSB + OR DL, AL + LOOP @@loop1 + +@@fin: + MOV EAX, EDX + POP EDI + POP ESI +end;} + +function FillMaskLine1( Mask, Scan : PByte; W : Integer ) + : Boolean; +assembler; +asm + PUSH ESI + PUSH EDI + MOV EDI, EAX + MOV ESI, EDX + MOV EDX, 0 + ADD ECX, 7 + SHR ECX, 3 + JZ @@fin + CLD +@@loop1: + LODSB + STOSB + OR DL, AL + LOOP @@loop1 + +@@fin: + MOV EAX, EDX + POP EDI + POP ESI +end; + +{function FillMaskBitmap(Mask: PBitmap; Width, Height: Integer; + Bits: PByte; BitsPerPixel, LineWidth, TransIndex: Integer): Boolean; +var Y : Integer; + P, S : PByte; +begin + Result := False; + if TransIndex < 0 then Exit; + P := Mask.ScanLine[ 0 ]; + if P = nil then Exit; + if BitsPerPixel = 4 then + for Y := Height - 1 downto 0 do + begin + P := Mask.ScanLine[ Y ]; + S := Bits; + Result := FillMaskLine4( P, S, Width, TransIndex ); + Inc( Bits, LineWidth ); + end; + if BitsPerPixel = 8 then + for Y := Height - 1 downto 0 do + begin + P := Mask.ScanLine[ Y ]; + S := Bits; + Result := FillMaskLine8( P, S, Width, TransIndex ); + Inc( Bits, LineWidth ); + end; + if BitsPerPixel = 1 then + for Y := Height - 1 downto 0 do + begin + P := Mask.ScanLine[ Y ]; + S := Bits; + if Byte( TransIndex ) = 0 then + Result := FillMaskLine0( P, S, Width ) + else + Result := FillMaskLine1( P, S, Width ); + Inc( Bits, LineWidth ); + end; +end;} + +procedure ProvideTruthMask( Sender: PObj; var BIH: TBitmapInfoHeader; Bits: Pointer ); +var Frame: PGifFrame; +begin + Frame := PGifFrame( Sender ); + if Frame.FTransIndex >= 0 then + begin + Frame.FTransMask := NewBitmap( BIH.biWidth, BIH.biHeight ); + Frame.FTransMask.PixelFormat := pf1bit; + + //Frame.FReallyTransparent := + {FillMaskBitmap( Frame.FTransMask, BIH.biWidth, BIH.biHeight, Bits, + BIH.biBitCount, + ((BIH.biWidth * BIH.biBitCount + 31) div 32) * 4, + Frame.FTransIndex );} + end; +end; + +function TGifFrame.GetBitmap: PBitmap; +var Mem : PStream; + + function ConvertBitsPerPixel: TPixelFormat; + begin + case FItem.FBitsPerPixel of + 1: Result := pf1bit; + 2..4: Result := pf4bit; + 5..8: Result := pf8bit; + else Result := pfDevice; + end; + end; + + procedure SaveToBmpStream; + var + HeaderSize: Longword; + Length: Longword; + BIH: TBitmapInfoHeader; + BFH: TBitmapFileHeader; + Colors: TRGBPalette; + Bits: Pointer; + Corrupt: Boolean; + begin + with BIH do begin + biSize := Sizeof(TBitmapInfoHeader); + biWidth := FItem.FSize.X; + biHeight := FItem.FSize.Y; + biPlanes := 1; + biBitCount := 0; + case ConvertBitsPerPixel of + pf1bit: biBitCount := 1; + pf4bit: biBitCount := 4; + else biBitCount := 8; + end; + biCompression := BI_RGB; + biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight; + biXPelsPerMeter := 0; + biYPelsPerMeter := 0; + biClrUsed := 0; + biClrImportant := 0; + end; + HeaderSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) + + SizeOf(TRGBQuad) * (1 shl BIH.biBitCount); + Length := HeaderSize + BIH.biSizeImage; + Mem.Size := 0; + with BFH do begin + bfType := $4D42; { 'BM' } + bfSize := Length; + bfOffBits := HeaderSize; + end; + Mem.Write(BFH, SizeOf(TBitmapFileHeader)); + Mem.Write(BIH, SizeOf(TBitmapInfoHeader)); + FillRGBPalette(FItem.FColorMap, Colors); + Mem.Write(Colors, SizeOf(TRGBQuad) * (1 shl BIH.biBitCount)); + Bits := AllocMemo(BIH.biSizeImage); + //try + ZeroMemory(Bits, BIH.biSizeImage); + FItem.FImageData.Seek( 0, spBegin ); + + ReadGIFData(FItem.FImageData, BIH, FInterlaced, + FItem.FBitsPerPixel, Bits, Corrupt); + FTransMask.Free; + FTransMask := nil; + + if Assigned( FOwner.FOnNeedMask ) then + FOwner.FOnNeedMask( @Self, BIH, Bits ); + (* + if FOwner.NeedMask then + begin + if FTransIndex >= 0 then + begin + FTransMask := NewBitmap( BIH.biWidth, BIH.biHeight ); + FTransMask.PixelFormat := pf1bit; + + FReallyTransparent := + FillMaskBitmap( FTransMask, BIH.biWidth, BIH.biHeight, Bits, + BIH.biBitCount, + ((BIH.biWidth * BIH.biBitCount + 31) div 32) * 4, + FTransIndex ); + {if not ReallyTransparent then + begin + FTransMask.Free; + FTransMask := nil; + end;} + end; + end; + *) + FCorrupted := FCorrupted or Corrupt; + FOwner.FCorrupted := FOwner.FCorrupted or FCorrupted; + Mem.Write(Bits^, BIH.biSizeImage); + //finally + FreeMemo(Bits); + //end; + Mem.Seek( 0, spBegin ); + end; + +begin + if FBitmap = nil then + begin + New_Bitmap; + Mem := NewMemoryStream; + SaveToBmpStream; + + //--SnapStream2File( Mem, GetStartDir + 'loaded_mem.bmp' ); + + FBitmap.LoadFromStream( Mem ); + + //--FBitmap.SaveToFile( GetStartDir + 'loaded.bmp' ); + + {$IFDEF TOPF16BIT} + FBitmap.PixelFormat := pf16bit; //&&& // ColorsToPixelFormat( 1 shl FItem.FBitsPerPixel ); + {$ELSE} + FBitmap.PixelFormat := pf24bit; + {$ENDIF} + //FBitmap.FreeResources; + Mem.Free; + end; + Result := FBitmap; +end; + +function TGifFrame.GetColorCount: Integer; +begin + Result := FItem.FColorMap.ColorCount; + Assert( Result <> 0, 'Unknown color count in gif frame bitmap' ); + {if (Result = 0) and Assigned( FBitmap ) and (FBitmap.Palette <> 0) then + GetObject( FBitmap.Palette, Sizeof( Integer ), @Result );} +end; + +function TGifFrame.GetComment: PStrList; +begin + Result := FindComment( True ); +end; + +function TGifFrame.GetHeight: Integer; +begin + if Assigned(FBitmap) or Assigned(FItem.FImageData) then + Result := Bitmap.Height + else Result := 0; +end; + +function TGifFrame.GetReallyTransparent: Boolean; +begin + GetBitmap; + Result := fReallyTransparent; +end; + +function TGifFrame.GetWidth: Integer; +begin + if Assigned(FBitmap) or Assigned(FItem.FImageData) then + Result := Bitmap.Width + else Result := 0; +end; + +function TGifFrame.LoadFromStream(Stream: PStream): Boolean; + function DoLoadStream : Boolean; + var + ImageDesc: TImageDescriptor; + I, TransIndex: Integer; + begin + //Result := False; + fTransIndex := -1; + // + FItem.FImageData.Free; + FItem.FImageData := NewMemoryStream; + // + ReadImageStream(Stream, FItem.FImageData, ImageDesc, FInterlaced, + FLocalColors, FCorrupted, FItem.FBitsPerPixel, FItem.FColorMap); + FItem.FImageData.Position := 0; + with ImageDesc do + begin + FTopLeft := MakePoint(ImageLeftPos, ImageTopPos); + FItem.FSize := MakePoint(ImageWidth, ImageHeight); + FItem.FPackedFields := PackedFields; + end; + if not FLocalColors then + FItem.FColorMap := FOwner.FGifData.DColorMap; + FDelay := 0; + if FExtensions <> nil then + begin + for I := 0 to FExtensions.Count - 1 do + with PExtension(FExtensions.Items[I])^ do + if FExtType = etGraphic then + begin + if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then + begin + TransIndex := FExtRec.GCE.TransparentColorIndex; + if FItem.FColorMap.ColorCount > TransIndex then + begin + fTransIndex := TransIndex; + FTranspColor := ItemToRGB(FItem.FColorMap.Colors[TransIndex]); + FTransparent := True; + end; + end + else + FTranspColor := clNone; + FDelay := Max(FExtRec.GCE.DelayTime * 10, FDelay); + FDisposalMethod := TDisposeMethod((FExtRec.GCE.PackedFields and + GCE_DISPOSAL_METHOD) shr 2); + end; + end; + Result := True; + end; + +begin + Result := DoLoadStream; + if not Result then + begin + FItem.FImageData.Free; + FItem.FImageData := nil; + end; +end; + +procedure TGifFrame.New_Bitmap; +begin + FBitmap.Free; + FBitmap := NewBitmap( 0, 0 ); +end; + +procedure TGifFrame.SetComment(const Value: PStrList); +begin + GetComment.Assign( Value ); +end; + +procedure TGifFrame.SetDelay(const Value: Word); +begin + if FDelay = Value then Exit; + //FOwner.Changing; + FDelay := Value; + if FDelay > 0 then + FOwner.FVersion := gv89a; + //FOwner.Changed; +end; + +procedure TGifFrame.SetDisposalMethod(const Value: TDisposeMethod); +begin + if FDisposalMethod = Value then Exit; + //FOwner.Changing; + FDisposalMethod := Value; + if Value <> dmUndefined then + FOwner.FVersion := gv89a; + //FOwner.Changed; +end; + +procedure TGifFrame.SetTopLeft(const Value: TPoint); +begin + if (FTopLeft.X = Value.X) and (FTopLeft.Y = Value.Y) then Exit; + //FOwner.Changing; + FTopLeft := Value; + FOwner.FGifWidth := Max(FOwner.FGifWidth, + FItem.FSize.X + FTopLeft.X); + FOwner.FGifHeight := Max(FOwner.FGifHeight, + FItem.FSize.Y + FTopLeft.Y); + //FOwner.Changed; +end; + +procedure TGifFrame.SetTranspColor(const Value: TColor); +begin + if FTranspColor = Value then Exit; + //FOwner.Changing; + if Value <> clNone then + FOwner.FVersion := gv89a; + FTranspColor := Value; + //FOwner.Changed; +end; + +procedure TGifFrame.StretchDraw(DC: HDC; Rect: TRect); +var OldMode: Integer; + OldOrgX: TPoint; +begin + GetBitmap; // need to create Mask if it is needed + if Mask = nil then + begin + OldMode := SetStretchBltMode( DC, HALFTONE ); + SetBrushOrgEx( DC, 0, 0, @ OldOrgX ); + Bitmap.StretchDraw( DC, Rect ); + SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil ); + SetStretchBltMode( DC, OldMode ); + end + else + begin + StretchBitmapMask( DC, Rect, Bitmap, Mask ); + end; +end; + +{ TGifDecoder } + +procedure TGifDecoder.Clear; +begin + FGifData.DComment.Free; + FGifData.DComment := nil; + ClearItems; + FGifWidth := 0; + FGifHeight := 0; + FCorrupted := FALSE; +end; + +procedure TGifDecoder.ClearItems; +var I: Integer; +begin + if FItems <> nil then + begin + for I := 0 to FItems.Count-1 do + PObj(FItems.Items[I]).Free; + FItems.Clear; + end; +end; + +function NewGifDecoder: PGifDecoder; +begin + new( Result, Create ); + Result.NewImage; + Result.FTransparent := True; + Result.FBkColor := clNone; +end; + +destructor TGifDecoder.Destroy; +begin + Clear; + FItems.Free; + inherited; +end; + +procedure TGifDecoder.FreeResources; +var I : Integer; +begin + if FItems <> nil then + for I := 0 to FItems.Count - 1 do + PGifFrame( FItems.Items[ I ] ).FreeResources; +end; + +function TGifDecoder.GetBitmap: PBitmap; +begin + if (FItems.Count > 0) then begin + if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then + Result := PGIFFrame(FItems.Items[FFrameIndex]).Bitmap + else Result := PGIFFrame(FItems.Items[0]).Bitmap + end + else + Result := nil; +end; + +function TGifDecoder.GetComment: PStrList; +begin + Result := FGifData.DComment; +end; + +function TGifDecoder.GetFrame: Integer; +begin + Result := FFrameIndex; +end; + +function TGifDecoder.GetFrameCount: Integer; +begin + Result := 0; + if FItems <> nil then + Result := FItems.Count; +end; + +function TGifDecoder.GetFrames(Idx: Integer): PGifFrame; +begin + Result := nil; + if Idx >= 0 then + Result := PGifFrame( FItems.Items[ Idx ] ); +end; + +function TGifDecoder.GetHeight: Integer; +begin + Result := FGifHeight; +end; + +function TGifDecoder.GetMask: PBitmap; +begin + if (FItems.Count > 0) then begin + if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then + Result := PGIFFrame(FItems.Items[FFrameIndex]).Mask + else Result := PGIFFrame(FItems.Items[0]).Mask + end + else + Result := nil; +end; + +function TGifDecoder.GetWidth: Integer; +begin + Result := FGifWidth; +end; + +function TGifDecoder.LoadFromFile(const FileName: String): Boolean; +var Strm : PStream; +begin + Strm := NewReadFileStream( FileName {, ofOpenRead or ofOpenExisting or ofShareDenyWrite} ); + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TGifDecoder.LoadFromResourceID(Instance: HInst; + ResID: Integer): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TGifDecoder.LoadFromResourceName(Inst: HInst; + RsrcName: PChar): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Inst, PChar( RsrcName ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TGifDecoder.LoadFromStream(Stream: PStream): Boolean; +var + SeparatorChar: Char; + NewItem: PGIFFrame; + Extensions: PList; + ScreenDesc: TScreenDescriptor; + Data: PStream; + + function ReadSignature(Stream: PStream) : Boolean; + var + I: TGIFVersion; + S: array[ 0..3 ] of Char; + begin + Result := False; + FVersion := gvUnknown; + S[ 3 ] := #0; + Stream.Read(S[0], 3); + //if CompareText(GIFSignature, S) <> 0 then + if GIFSignature <> S then + //GifError( 'Incorrect GIF Version' ); + Exit; + Stream.Read(S[0], 3); + for I := Low(TGIFVersion) to High(TGIFVersion) do + //if CompareText(S, StrPas(GIFVersionStr[I])) = 0 then + if CompareMem( @S[ 0 ], PChar( GifVersionStr[ I ] ), 4 ) then + begin + FVersion := I; + Break; + end; + if FVersion = gvUnknown then + //GifError('Unknown GIF Version'); + Exit; + Result := True; + end; + + procedure ReadScreenDescriptor(Stream: PStream); + begin + Stream.Read(ScreenDesc, SizeOf(ScreenDesc)); + FGifWidth := ScreenDesc.ScreenWidth; + FGifHeight := ScreenDesc.ScreenHeight; + FGifData.DAspectRatio := ScreenDesc.AspectRatio; + FGifData.DBitsPerPixel := 1 + (ScreenDesc.PackedFields and + LSD_COLOR_TABLE_SIZE); + FGifData.DColorResBits := 1 + (ScreenDesc.PackedFields and + LSD_COLOR_RESOLUTION) shr 4; + end; + + procedure ReadGlobalColorMap(Stream: PStream); + begin + if (ScreenDesc.PackedFields and LSD_GLOBAL_COLOR_TABLE) <> 0 then + begin + FGifData.DColorMap.ColorCount := 1 shl FGifData.DBitsPerPixel; + Stream.Read( FGifData.DColorMap.Colors[0], + FGifData.DColorMap.ColorCount * SizeOf(TGIFColorItem) ); + {if FGifData.DColorMap.ColorCount > ScreenDesc.BackgroundColorIndex then + begin + fBackIndex := ScreenDesc.BackgroundColorIndex; + FBkColor := ItemToRGB( FGifData.DColorMap.Colors[ fBackIndex ] ); + end;} + fBackIndex := ScreenDesc.BackgroundColorIndex; + if fBackIndex >= FGifData.DColorMap.ColorCount then + fBackIndex := 0; + FBkColor := ItemToRGB( FGifData.DColorMap.Colors[fBackIndex] ); + end; + end; + + function ReadDataBlock(Stream: PStream): PStrList; + var + BlockSize: Byte; + S: string; + begin + Result := NewStrlist; + //try + repeat + Stream.Read(BlockSize, SizeOf(Byte)); + if BlockSize <> 0 then begin + SetLength(S, BlockSize); + Stream.Read(S[1], BlockSize); + Result.Add(S); + end; + until (BlockSize = 0) or (Stream.Position >= Stream.Size); + //except + { + Result.Free; + raise; + } + //end; + end; + + function ReadExtension(Stream: PStream): PExtension; + var + ExtensionLabel: Byte; + begin + //Result := TExtension.Create; + new( Result, Create ); + //try + Stream.Read(ExtensionLabel, SizeOf(Byte)); + if ExtensionLabel = ExtLabels[etGraphic] then + begin + { graphic control extension } + Result.FExtType := etGraphic; + Stream.Read(Result.FExtRec.GCE, SizeOf(TGraphicControlExtension)); + end + else + if ExtensionLabel = ExtLabels[etComment] then + begin + { comment extension } + Result.FExtType := etComment; + Result.FList := ReadDataBlock(Stream); + end + else + if ExtensionLabel = ExtLabels[etPlainText] then + begin + { plain text extension } + Result.FExtType := etPlainText; + Stream.Read(Result.FExtRec.PTE, SizeOf(TPlainTextExtension)); + Result.FList := ReadDataBlock(Stream); + end + else + if ExtensionLabel = ExtLabels[etApplication] then + begin + { application extension } + Result.FExtType := etApplication; + Stream.Read(Result.FExtRec.APPE, SizeOf(TAppExtension)); + Result.FList := ReadDataBlock(Stream); + end + else + begin + //GifError('Unrecognized GIF Extention ' + IntToStr( ExtensionLabel ) ); + //... + Result.Free; + Result := nil; + end; + //except + { + Result.Free; + raise; + } + //end; + end; + + function ReadExtensionBlock(Stream: PStream; var SeparatorChar: Char): PList; + var + NewExt: PExtension; + begin + Result := nil; + //try + while SeparatorChar = CHR_EXT_INTRODUCER do + begin + NewExt := ReadExtension(Stream); + if (NewExt.FExtType = etPlainText) then + begin + { plain text data blocks are not supported, + clear all previous readed extensions } + FreeExtensions(Result); + Result := nil; + end; + if (NewExt.FExtType in [etPlainText, etApplication]) then + begin + { check for loop extension } + if NewExt.IsLoopExtension then + begin + FLooping := True; + FRepeatCount := Min( PWord( @NewExt.FList.Items[0][2] )^, + //MakeWord(Byte(NewExt.FList.Items[0][2]), + //Byte(NewExt.FList.Items[0][3])), + MAX_LOOP_COUNT); + end; + { not supported yet, must be ignored } + NewExt.Free; + end + else + begin + if Result = nil then + Result := NewList; + Result.Add(NewExt); + end; + if Stream.Size > Stream.Position then + Stream.Read(SeparatorChar, SizeOf(Byte)) + else + SeparatorChar := CHR_TRAILER; + end; + if (Result <> nil) and (Result.Count = 0) then + begin + Result.Free; + Result := nil; + end; + //except + { + if Result <> nil then Result.Free; + raise; + } + //end; + end; + + function DoLoadStream : Boolean; + var + Size : Integer; + I, OldPos: Integer; + Ext: PExtension; + Idx : Integer; + begin + Size := Stream.Size - Stream.Position; + Result := False; + //Changing; + NewImage; + Idx := 0; + Data := NewMemoryStream; + //try + Data.Size := Size; + Stream.Read(Data.Memory^, Size); + if Size > 0 then + begin + Data.Seek( 0, spBegin ); + if not ReadSignature(Data) then Exit; + ReadScreenDescriptor(Data); + ReadGlobalColorMap(Data); + Data.Read(SeparatorChar, SizeOf(Byte)); + OldPos := -1; + while not (SeparatorChar in [CHR_TRAILER, #0]) and not + (Data.Position >= Data.Size) and (DWORD(OldPos) <> Data.Position) do + begin + OldPos := Data.Position; + Extensions := ReadExtensionBlock(Data, SeparatorChar); + if SeparatorChar = CHR_IMAGE_SEPARATOR then + begin + //try + NewItem := NewGIFFrame(@Self); + NewItem.fFrameIndex := Idx; + Inc( Idx ); + //try + if FGifData.DColorMap.ColorCount > 0 then + NewItem.FItem.FBitsPerPixel := + ColorsToBits(FGifData.DColorMap.ColorCount); + NewItem.FExtensions := Extensions; + Extensions := nil; + if not NewItem.LoadFromStream(Data) then + begin + NewItem.Free; + Exit; + end; + FItems.Add(NewItem); + //except + { + NewItem.Free; + raise; + } + //end; + if not (Data.Position >= Data.Size) then + begin + Data.Read(SeparatorChar, SizeOf(Byte)); + while (SeparatorChar = #0) and (Data.Position < Data.Size) do + Data.Read(SeparatorChar, SizeOf(Byte)); + end + else + SeparatorChar := CHR_TRAILER; + if not (SeparatorChar in [CHR_EXT_INTRODUCER, + CHR_IMAGE_SEPARATOR, CHR_TRAILER]) then + begin + SeparatorChar := #0; + {GifError(LoadStr(SGIFDecodeError));} + //Corrupted := TRUE; + //break; + end; + //except + { + FreeExtensions(Extensions); + raise; + } + //end + end + else + if (FGifData.DComment.Count = 0) and (Extensions <> nil) then + begin + //try + { trailig extensions } + for I := 0 to Extensions.Count - 1 do + begin + Ext := Extensions.Items[I]; + if (Ext <> nil) and (Ext.FExtType = etComment) then + begin + if FGifData.DComment.Count > 0 then + FGifData.DComment.Add(#13#10#13#10); + FGifData.DComment.AddStrings(Ext.FList); + end; + end; + //finally + FreeExtensions(Extensions); + //end; + end + else + if not (SeparatorChar in [CHR_TRAILER, #0]) then + begin + //GifError('GIF Read Error'); + //... + FreeExtensions(Extensions); + FCorrupted := TRUE; + end; + end; + end; + //finally + //Data.Free; + //end; + if Count > 0 then + begin + FFrameIndex := 0; + //if ForceDecode then + //try + GetBitmap; { force bitmap creation } + FTransparent := Frames[ 0 ].FTransparent; + //except + { + Frames[0].Free; + FItems.Delete(0); + raise; + } + //end; + end; + //Changed; + //if not Corrupted then + Result := True; + end; + +begin + Clear; + Result := DoLoadStream; + Data.Free; + if not Result then Clear; +end; + +procedure TGifDecoder.NewImage; +begin + FGifData.DComment.Free; + FGifData.DComment := NewStrList; + + if FItems = nil then FItems := NewList; + ClearItems; + FFrameIndex := -1; + FBkColor := clNone; + FRepeatCount := 1; + FLooping := False; + FVersion := gvUnknown; +end; + +procedure TGifDecoder.SetFrame(Value: Integer); +begin + If FFrameIndex = Value Then Exit; + //Changing; + FFrameIndex:= Value; + If (FFrameIndex >= FItems.Count) Or (FFrameIndex < 0) Then FFrameIndex:= 0; + //Changed; +end; + +procedure TGifDecoder.SetNeedMask(const Value: Boolean); +begin + FNeedMask := Value; + if Value then + FOnNeedMask := ProvideTruthMask + else + FOnNeedMask := nil; +end; + +{ TGif } + +function NewGifNoMask: PGif; +begin + new( Result, Create ); + Result.FGifImage := NewGifDecoder; +end; + +function NewGif: PGif; +begin + Result := NewGifNoMask; + Result.FGifImage.NeedMask := TRUE; +end; + +procedure TGif.Clear; +begin + FGifImage.Clear; + FCurIndex := -1; + FCurFrame.Free; FCurFrame := nil; + FCurMask.Free; FCurMask := nil; + FPrevFrame.Free; FPrevFrame := nil; + FPrevMask.Free; FPrevMask := nil; + Changed; +end; + +destructor TGif.Destroy; +begin + //OnChanging := nil; + //OnChanged := nil; + Clear; + FGifImage.Free; + inherited; +end; + +procedure TGif.Draw(DC: HDC; X, Y: Integer); +begin + if Count = 0 then Exit; + PrepareFrame; + FCurFrame.Draw( DC, X, Y ); +end; + +procedure TGif.DrawTransp(DC: HDC; X, Y: Integer); +begin + If Count > 0 Then DrawTransparent( DC, X, Y, Frames[ Frame ].TranspColor ); +end; + +procedure MyDraw(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer; Bmp, Msk: PBitmap); +begin + BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc); + BitBlt(DC, X, Y, iWidth, iHeight, Msk.Canvas.Handle, SrcX, SrcY, SrcAnd); + BitBlt(DC, X, Y, iWidth, iHeight, Bmp.Canvas.Handle, SrcX, SrcY, SrcPaint); +end; +procedure TGif.DrawTransparentEx(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer); +begin + If Count = 0 then Exit; + PrepareFrame; + If FCurMask = Nil Then + BitBlt(DC, X, Y, iWidth, iHeight, FCurFrame.Canvas.Handle, SrcX, SrcY, SrcCopy) + Else + MyDraw(DC, X, Y, iWidth, iHeight, SrcX, SrcY, FCurFrame, FCurMask); +end; + +procedure TGif.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor); +begin + if Count = 0 then Exit; + PrepareFrame; + //----------------------------------------------------------------------- + {if FCurMask <> nil then + FCurMask.SaveToFile( GetStartDir + 'TGif.DrawTransparent.FCurMask.bmp' ) + else + DeleteFile( PChar( GetStartDir + 'TGif.DrawTransparent.FCurMask.bmp' ) ); + if FCurFrame <> nil then + FCurFrame.SaveToFile( GetStartDir + 'TGif.DrawTransparent.FCurFrame.bmp' ) + else + DeleteFile( PChar( GetStartDir + 'TGif.DrawTransparent.FCurFrame.bmp' ) );} + //------------------------------------------------------------------------- + if FCurMask = Nil Then + FCurFrame.Draw( DC, X, Y ) + Else + DrawBitmapMask( DC, X, Y, FCurFrame, FCurMask ); +end; + +procedure TGif.FreeResources; +begin + FGifImage.FreeResources; + if FCurFrame <> nil then + FCurFrame.Dormant; + if FCurMask <> nil then + FCurMask.Dormant; + if FPrevFrame <> nil then + FPrevFrame.Dormant; + if FPrevMask <> nil then + FPrevMask.Dormant; +end; + +function TGif.GetHeight: Integer; +begin + Result := FGifImage.Height; +end; + +function TGif.GetWidth: Integer; +begin + Result := FGifImage.Width; +end; + +procedure TGif.StretchDrawTransp(DC: HDC; const Dest: TRect); +begin + if Count = 0 then Exit; + StretchDrawTransparent( DC, Dest, BkColor ); +end; + +procedure TGif.StretchDraw(DC: HDC; const Dest: TRect); + var OldMode: Integer; OldOrgX: TPoint; +begin + if Count = 0 then Exit; + PrepareFrame; + OldMode := SetStretchBltMode( DC, HALFTONE ); + SetBrushOrgEx( DC, 0, 0, @ OldOrgX ); + FCurFrame.StretchDraw( DC, Dest ); + SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil ); + SetStretchBltMode( DC, OldMode ); +end; + +procedure TGif.StretchDrawTransparent(DC: HDC; const Dest: TRect; TranspColor: TColor); +begin + if Count = 0 then Exit; + PrepareFrame; + if FCurMask = nil then + FCurFrame.StretchDraw( DC, Dest ) + else + StretchBitmapMask( DC, Dest, FCurFrame, FCurMask ); +end; + +procedure TGif.PrepareFrame; +var DM : TDisposeMethod; I : Integer; + procedure DrawCurFrameMask; + var F: PGifFrame; + begin + F := Frames[ FCurIndex ]; + F.GetBitmap; + //if F.ReallyTransparent then + if F.Mask <> nil then + begin + BitBlt( FCurMask.Canvas.Handle, + F.Origin.x, + F.Origin.y, + F.Origin.X + F.Width, + F.Origin.Y + F.Height, + F.Mask.Canvas.Handle, 0, 0, SRCAND ); + {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} + end + else + begin + //^^^FCurMask.Canvas.Brush.Color := clBlack; + FCurMask.BkColor := clBlack; + FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, + F.Origin.x + F.Width, F.Origin.y + F.Height ) ); + end; + end; + procedure Prepare0; + var Frame0: PGifFrame; + begin + FCurIndex := 0; + Frame0 := Frames[ 0 ]; + FCurFrame.PixelFormat := Frame0.Bitmap.PixelFormat; + //^^^FCurFrame.Canvas.Brush.Color := BkColor; + FCurFrame.BkColor := BkColor; + FCurFrame.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) ); + if FCurMask <> nil then + begin + //^^^FCurMask.Canvas.Brush.Color := clWhite; + FCurMask.BkColor := clWhite; + FCurMask.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) ); + end; + Frame0.Draw( FCurFrame.Canvas.Handle, Frame0.Origin.x, Frame0.Origin.y ); + + //FCurFrame.SaveToFile( GetStartDir + '0_Frame.bmp' ); + + if FCurMask <> nil then + begin + + DrawCurFrameMask; + + //FCurMask.SaveToFile( GetStartDir + '0_Mask.bmp' ); + end; + end; +var F: PGifFrame; +begin + if Count = 0 then Exit; + if FCurFrame = nil then + begin + FCurFrame := NewBitmap( Width, Height ); + {$IFDEF TOPF16BIT} + FCurFrame.PixelFormat := pf16bit; //&&& + {$ELSE} + FCurFrame.PixelFormat := pf24bit; + {$ENDIF} + + if Transparent then + begin + FCurMask := NewBitmap( Width, Height ); + FCurMask.PixelFormat := pf1bit; + end; + + FCurIndex := -1; + end; + if FCurIndex >= 0 then + if Frames[ FCurIndex ].ReallyTransparent then + if FCurMask = nil then + begin + FCurMask := NewBitmap( Width, Height ); + FCurMask.PixelFormat := pf1bit; + //^^^FCurMask.Canvas.Brush.Color := clWhite; + FCurMask.BkColor := clBlack; //---%%%--- + FCurMask.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) ); + end; + if (FCurIndex < 0) or (FCurIndex > Frame) then + Prepare0; + while FCurIndex < Frame do + begin + DM := Frames[ FCurIndex ].DisposalMethod; + if DM = dmRestorePrevious then + if FCurIndex = 0 then + DM := dmRestoreBackground; + if DM = dmUndefined then + for I := FCurIndex - 1 downto 0 do + if Frames[ I ].DisposalMethod <> DM then + begin + DM := Frames[ I ].DisposalMethod; + break; + end; + if (DM = dmUndefined) and Frames[ FCurIndex + 1 ].Transparent then + DM := dmLeave; + case DM of + dmRestoreBackground: + begin + + //^^^FCurFrame.Canvas.Brush.Color := BkColor; + FCurFrame.BkColor := BkColor; + + F := Frames[ FCurIndex ]; + FCurFrame.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, F.Origin.x + F.Width, + F.Origin.y + F.Height ) ); + if FCurMask <> nil then + begin + //^^^FCurMask.Canvas.Brush.Color := clWhite; + FCurMask.BkColor := clWhite; + + if FCurIndex < Count then + begin + Frames[ FCurIndex + 1 ].GetBitmap; + if Frames[ FCurIndex + 1 ].Mask = nil then + //^^^FCurMask.Canvas.Brush.Color := clBlack; + FCurMask.BkColor := clBlack; + end; + FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, + F.Origin.x + F.Width, F.Origin.y + F.Height ) ); + end; + + end; + dmRestorePrevious: + begin + FCurFrame.Assign( FPrevFrame ); + if FCurMask <> nil then + FCurMask.Assign( FPrevMask ); + if FCurMask <> nil then + if FCurMask.Empty then + begin + FCurMask.Free; + FCurMask := nil; + end; + end; + dmUndefined: + begin + F := Frames[ FCurIndex + 1 ]; + //^^^FCurFrame.Canvas.Brush.Color := BkColor; + FCurFrame.BkColor := BkColor; + FCurFrame.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, + F.Origin.x + F.Width, F.Origin.y + F.Height ) ); + if FCurMask <> nil then + begin + //^^^FCurMask.Canvas.Brush.Color := clBlack; + FCurMask.BkColor := clBlack; + FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, + F.Origin.x + F.Width, F.Origin.y + F.Height ) ); + end; + end; + end; + Inc( FCurIndex ); + F := Frames[ FCurIndex ]; + if F.DisposalMethod = dmRestorePrevious then + begin + if FPrevFrame = nil then + FPrevFrame := NewBitmap( 0, 0 ); + FPrevFrame.Assign( FCurFrame ); + if FCurMask <> nil then + begin + if FPrevMask = nil then + FPrevMask := NewBitmap( 0, 0 ); + FPrevMask.Assign( FCurMask ); + end; + end; + F.Draw( FCurFrame.Canvas.Handle, F.Origin.x, F.Origin.y ); + + //F.Bitmap.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + 'img.bmp' ); + //FCurFrame.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + '=fr.bmp' ); + + if FCurMask <> nil then + begin + //if F.Mask <> nil then F.Mask.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + 'Msk.bmp' ); + DrawCurFrameMask; + //--------------------- + //FCurMask.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + '=MS.bmp' ); + //--------------------- + end; + end; +end; + +function TGif.GetBkColor: TColor; +begin + Result := FGifImage.BkColor; +end; + +procedure TGif.SetBkColor(const Value: TColor); +begin + FGifImage.BkColor := Value; + Changed; +end; + +function TGif.GetFrames(Idx: Integer): PGifFrame; +begin + Result := FGifImage.Frames[ Idx ]; +end; + +function TGif.GetTransparent: Boolean; +begin + Result := FGifImage.Transparent; +end; + +function TGif.GetFrame: Integer; +begin + Result := FGifImage.FFrameIndex; +end; + +procedure TGif.SetFrame(Value: Integer); +begin + if Value >= Count then + Value := 0; + FGifImage.Frame := Value; +end; + +function TGif.LoadFromStream(Stream: PStream): Boolean; +begin + Clear; + Result := FGifImage.LoadFromStream( Stream ); + Changed; +end; + +function TGif.LoadFromFile(const FileName: String): Boolean; +begin + Clear; + Result := FGifImage.LoadFromFile( FileName ); + Changed; +end; + +function TGif.GetFrameCount: Integer; +begin + Result := FGifImage.Count; +end; + +function TGif.GetDelays(Idx: Integer): Integer; +begin + Result := 0; + if Idx < Count then + Result := Frames[ Idx ].Delay; +end; + +procedure TGif.SetDelays(Idx, Value: Integer); +begin + Frames[ Idx ].Delay := Value; + Changed; +end; + +procedure TGif.SetWidth(Value: Integer); +begin + // nothing! +end; + +procedure TGif.SetHeight(Value: Integer); +begin + // nothing ! +end; + +{ +procedure TGif.SetForceBkTransparent(const Value: Boolean); +begin + if FForceBkTransparent = Value then Exit; + FForceBkTransparent := Value; + FCurIndex := -1; +end; +} + +function TGif.GetCorrupted: Boolean; +begin + Result := FGifImage.Corrupted; +end; + +procedure TGif.Changed; +begin + if Assigned( FOnChanged ) then + FOnChanged( @Self ); +end; + +//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +//+ TGifShow - a control to show (animated) GIF on a form. + +//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +type + PGifShowData = ^TGifShowData; + TGifShowData = object( TObj ) + gsdGifShow: PGifShow; + gsdAutosize: Boolean; + gsdStretch: Boolean; + gsdAnimate: Boolean; + gsdLoop: Boolean; + //gsdTimer: PTimer; + gsdTimerSet: Integer; + gsdGif: PGif; + gsdOnEndLoop: TOnEvent; + destructor Destroy; virtual; + end; + +function NewGifShow( AParent: PControl ): PGifShow; +var D: PGifShowData; +begin + Result := PGifShow( NewPaintBox( AParent ) ); + new( D, Create ); + D.gsdGifShow := Result; + D.gsdAutosize := TRUE; + D.gsdStretch := TRUE; + D.gsdAnimate := TRUE; + D.gsdLoop := TRUE; + D.gsdGif := NewGif; + D.gsdGif.FOnChanged := Result.GifChanged; + Result.CustomObj := D; + Result.SetOnPaint( Result.PaintFrame ); +end; + +function TGif.LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TGif.LoadFromResourceName(Inst: HInst; RsrcName: PChar): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Inst, PChar( RsrcName ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +{ TGifShow } + +function TGifShow.GetAnimate: Boolean; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdAnimate; +end; + +function TGifShow.GetAutosize: Boolean; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdAutosize; +end; + +function TGifShow.GetDummy: Boolean; +begin + Result := FALSE; +end; + +function TGifShow.GetGif: PGif; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdGif; +end; + +function TGifShow.GetLoop: Boolean; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdLoop; +end; + +function TGifShow.GetOnEndLoop: TOnEvent; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdOnEndLoop; +end; + +function TGifShow.GetStretch: Boolean; +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + Result := D.gsdStretch; +end; + +procedure GoNextFrame( Wnd: HWnd; Msg: DWORD; GifShow: PGifShow; dwTime: DWORD ); +stdcall; +begin + GifShow.NextFrame( nil ); +end; + +procedure TGifShow.GifChanged(Sender: PObj); +var D: PGifShowData; + NewDelay: Integer; +begin + D := Pointer( CustomObj ); + if (D.gsdGif.Count > 1) and D.gsdAnimate then + begin + NewDelay := Max( 1, D.gsdGif.Frames[ 0 ].Delay ); + if D.gsdTimerSet = 0 then + begin + D.gsdTimerSet := NewDelay; + SetTimer( GetWindowHandle, DWORD( @ Self ), D.gsdTimerSet, @ GoNextFrame ); + end; + end + else + if D.gsdTimerSet <> 0 then + begin + KillTimer( Handle, DWORD( @ Self ) ); + D.gsdTimerSet := 0; + end; + if D.gsdAutosize then + SetAutosize( TRUE ); + Invalidate; +end; + +function TGifShow.LoadFromFile(const FileName: String): Boolean; +begin + Result := Gif.LoadFromFile( FileName ); +end; + +function TGifShow.LoadFromResourceID(Instance: HInst; + ResID: Integer): Boolean; +begin + Result := Gif.LoadFromResourceID( Instance, ResID ); +end; + +function TGifShow.LoadFromResourceName(Inst: HInst; + RsrcName: PChar): Boolean; +begin + Result := Gif.LoadFromResourceName( Inst, RsrcName ); +end; + +function TGifShow.LoadFromStream(Stream: PStream): Boolean; +begin + Result := Gif.LoadFromStream( Stream ); +end; + +procedure TGifShow.NextFrame(Sender: PObj); +var D: PGifShowData; + NewDelay: Integer; +begin + D := Pointer( CustomObj ); + if D.gsdGif.Frame >= D.gsdGif.Count-1 then + begin + if D.gsdLoop then + begin + D.gsdGif.Frame := 0; + //D.gsdTimer.Interval := D.gsdGif.Frames[ 0 ].Delay; + end + else + begin + D.gsdAnimate := FALSE; + end; + if Assigned( D.gsdOnEndLoop ) then + D.gsdOnEndLoop( @ Self ); + end + else + D.gsdGif.Frame := D.gsdGif.Frame + 1; + Invalidate; + NewDelay := Max( 1, D.gsdGif.Frames[ D.gsdGif.Frame ].Delay ); + if D.gsdTimerSet <> NewDelay then + begin + if D.gsdTimerSet <> 0 then + KillTimer( Handle, DWORD( @Self ) ); + D.gsdTimerSet := NewDelay; + SetTimer( Handle, DWORD( @ Self ), NewDelay, @ GoNextFrame ); + end; +end; + +procedure TGifShow.PaintFrame(Sender: PControl; DC: HDC); +var D: PGifShowData; + Br: HBrush; +begin + D := Pointer( CustomObj ); + if (D.gsdGif.Width > 0) and (D.gsdGif.Height > 0) then + begin + if Stretch and ((D.gsdGif.Width <> Width) or (D.gsdGif.Height <> Height)) then + if Transparent then + D.gsdGif.StretchDrawTransp( DC, ClientRect ) + else + D.gsdGif.StretchDraw( DC, ClientRect ) + else + if Transparent then + D.gsdGif.DrawTransp( DC, 0, 0 ) + else + D.gsdGif.Draw( DC, 0, 0 ); + end + else + begin + if not Transparent then + begin + Br := CreateSolidBrush( Color2RGB( Color ) ); + Windows.FillRect( DC, ClientRect, Br ); + DeleteObject( Br ); + end; + end; +end; + +procedure TGifShow.SetAnimate(const Value: Boolean); +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + D.gsdAnimate := Value; + GifChanged( nil ); +end; + +procedure TGifShow.SetAutosize(const Value: Boolean); +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + D.gsdAutosize := Value; + if Value and (D.gsdGif.Width > 0) and (D.gsdGif.Height > 0) then + begin + Width := D.gsdGif.Width; + Height := D.gsdGif.Height; + end; +end; + +procedure TGifShow.SetLoop(const Value: Boolean); +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + if D.gsdLoop = Value then Exit; + D.gsdLoop := Value; + GifChanged( nil ); +end; + +procedure TGifShow.SetOnEndLoop(const Value: TOnEvent); +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + D.gsdOnEndLoop := Value; +end; + +procedure TGifShow.SetStretch(const Value: Boolean); +var D: PGifShowData; +begin + D := Pointer( CustomObj ); + D.gsdStretch := Value; + Invalidate; +end; + +{ TGifShowData } + +destructor TGifShowData.Destroy; +begin + //gsdTimer.Free; + if gsdTimerSet <> 0 then + KillTimer( gsdGifShow.Handle, DWORD( gsdGifShow ) ); + gsdGif.Free; + inherited; +end; + +end. diff --git a/Addons/KOLGraphicColor.pas b/Addons/KOLGraphicColor.pas new file mode 100644 index 0000000..220b9a1 --- /dev/null +++ b/Addons/KOLGraphicColor.pas @@ -0,0 +1,4111 @@ +unit KOLGraphicColor; + +// This file is part of the image library GraphicEx (www.lischke-online.de/Graphics.html). +// +// GraphicColor contains the implementation of the color conversion manager. +// This class is responsible for converting between these color schemes/formats: +// - RGB(A) +// - BGR(A) +// - CMY(K) +// - CIE L*a*b* +// - PhotoYCC, standard YCbCr +// - indexed +// - grayscale (with alpha, which is ignored currently) +// +// Additional tasks are: +// - coversions between bit depths (1,2,4,8,16 bits) +// - palette creation +// - gamma tables creation and application +// - masked pixel transfer for interlaced images +// - big endian swap +// - plane (planar) -> interleaved (interlaced) conversion +// +// Notes: +// - Throughout the entire unit I used the terms BPS and SPP for "bits per sample" and +// "samples per pixel", respectively. A sample is one component per pixel. For indexed color schemes +// there's only 1 sample per pixel, for RGB there are 3 (red, green and blue) and so on. +// - The bit depth of multi sample formats like RGB must be equal for each color component. +// - Because of the large amount of possible combinations (color schemes, sample depth, gamma, byte swap) +// I limited the accepted combinations to pratical ones. This leaves currently out: +// + gamma correction for 16 bit values +// + conversion to 16 bit (target) grayscale with alpha +// + samples sizes less than 8 bits for multi-sample schemes (RGB etc.) +// + indexed schemes with planes (e.g. 16 colors indexed as 4 planes each with one bit per sample) +// - For now there is no conversion between indexed and non-indexed formats. Also between grayscale +// and any other scheme is no conversion possible. +// +// (c) Copyright 1999, 2000 Dipl. Ing. Mike Lischke (public@lischke-online.de). All rights reserved. +// +// This package is freeware for non-commercial use only. +// Contact author for licenses (shareware@lischke-online.de) and see License.txt which comes with the package. + +////////////////////////////////////////////////// +// Converted to KOL by Dimaxx (dimaxx@atnet.ru) // +////////////////////////////////////////////////// + +interface + +{$ALIGN OFF} + +uses Windows, KOL, Err, Errors; + +const + // this is the value for average CRT monitors, adjust it if your monitor differs + DefaultDisplayGamma = 2.2; + +type + TColorScheme = ( + csUnknown, // not (yet) defined color scheme + csIndexed, // any palette format + csG, // gray scale + csGA, // gray scale with alpha channel + csRGB, // red, green, blue + csRGBA, // RGB with alpha channel + csBGR, // RGB in reversed order (used under Windows) + csBGRA, // BGR with alpha channel (alpha is always the last component) + csCMY, // cyan, magenta, yellow (used mainly for printing processes) + csCMYK, // CMY with black + csCIELab, // CIE color format using luminance and chromaticities + csYCbCr, // another format using luminance and chromaticities + csPhotoYCC // a modified YCbCr version used for photo CDs + ); + + TConvertOptions = set of ( + coAlpha, // alpha channel is to be considered (this value is + // usually automatically set depending on the color scheme) + coApplyGamma, // target only, gamma correction must take place + coNeedByteSwap, // endian switch needed + coLabByteRange, // CIE L*a*b* only, luminance range is from 0..255 instead 0..100 + coLabChromaOffset); // CIE L*a*b* only, chrominance values a and b are given in 0..255 instead -128..127 + + // format of the raw data to create a color palette from + TRawPaletteFormat = ( + pfInterlaced8Triple, // rgb triple with 8 bits per component + pfInterlaced8Quad, // rgb quad with 8 bits per component (fourth entry is reserved as in Windows' logical palette) + pfPlane8Triple, // 3 separate planes of data with 8 bits per component + pfPlane8Quad, + pfInterlaced16Triple, // rgb triple with 16 bits per component + pfInterlaced16Quad, + pfPlane16Triple, // 3 separate planes of data with 16 bits per component + pfPlane16Quad); + + // TConversionMethod describes the general parameter list to which each implemented conversion method conforms. + // Note: Source is defined as open array parameter to allow plane and interlaced source data. + TConversionMethod = procedure(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte) of object; + + PColorManager = ^TColorManager; + TColorManager = object(TObj) + private + FChanged: boolean; // set if any of the parameters changed + FSourceBPS, // bits per sample of source data (allowed values are 1, 2, 4, 8, 16) + FTargetBPS, // bits per sample of target data (allowed values are 1, 2, 4, 8, 16) + FSourceSPP, // samples per source pixel (allowed values are 1, 3, 4) + FTargetSPP: byte; // samples per target pixel (allowed values are 1, 3, 4) + FMainGamma, // primary gamma value which is usually read from a file (default is 1) + FDisplayGamma: single; // (constant) gamma value of the current monitor (default is 2.2) + FGammaTable: array[Byte] of byte; // contains precalculated gamma values for each possible component value + // (range is 0..255) + FYCbCrCoefficients: array[0..2] of single; + FHSubsampling, + FVSubSampling: byte; // additional parameters used for YCbCr conversion + FCrToRedTable, // lookup tables used for YCbCr conversion + FCbToBlueTable, + FCrToGreenTable, + FCbToGreenTable: array of integer; + FSourceScheme,FTargetScheme: TColorScheme; + FRowConversion: TConversionMethod; // procedure variable for the actual conversion method used + FSourceOptions, + FTargetOptions: TConvertOptions; // options to control conversion + protected + // Low level conversion helper used to convert one pixel component. + function ComponentGammaConvert(Value: byte): byte; + function ComponentNoConvert16(Value: word): word; + function ComponentNoConvert8(Value: byte): byte; + function ComponentScaleConvert(Value: word): byte; + function ComponentScaleGammaConvert(Value: word): byte; + function ComponentSwapScaleGammaConvert(Value: Word): byte; + function ComponentSwapScaleConvert(Value: word): byte; + function ComponentSwapConvert(Value: word): word; + // row conversion routines + procedure RowConvertBGR2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertBGR2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertCIELAB2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertCIELAB2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertCMYK2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertCMYK2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertGray(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertIndexed8(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertIndexedBoth16(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertIndexedSource16(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertIndexedTarget16(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertRGB2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertRGB2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertPhotoYCC2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertPhotoYCC2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertYCbCr2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure RowConvertYCbCr2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + + // other general routines + procedure CreateYCbCrLookup; + function GetPixelFormat(Index: integer): TPixelFormat; + procedure PrepareConversion; + procedure SetSourceBitsPerSample(const Value: byte); + procedure SetSourceColorScheme(const Value: TColorScheme); + procedure SetSourceSamplesPerPixel(const Value: byte); + procedure SetTargetBitsPerSample(const Value: byte); + procedure SetTargetColorScheme(const Value: TColorScheme); + procedure SetTargetSamplesPerPixel(const Value: byte); + public +// constructor Create; + procedure ConvertRow(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); + procedure CreateColorPalette(BMP: PBitmap; Data: array of pointer; DataFormat: TRawPaletteFormat; ColorCount: cardinal; RGB: boolean); + procedure CreateGrayscalePalette(BMP: PBitmap; MinimumIsWhite: boolean); + procedure Error(Code: integer); + procedure SetGamma(MainGamma: single; DisplayGamma: single = DefaultDisplayGamma); + procedure SetYCbCrParameters(Values: array of single; HSubSampling,VSubSampling: byte); + + property SourceBitsPerSample: byte read FSourceBPS write SetSourceBitsPerSample; + property SourceColorScheme: TColorScheme read FSourceScheme write SetSourceColorScheme; + property SourceOptions: TConvertOptions read FSourceOptions write FSourceOptions; + property SourcePixelFormat: TPixelFormat index 0 read GetPixelFormat; + property SourceSamplesPerPixel: byte read FSourceSPP write SetSourceSamplesPerPixel; + property TargetBitsPerSample: byte read FTargetBPS write SetTargetBitsPerSample; + property TargetColorScheme: TColorScheme read FTargetScheme write SetTargetColorScheme; + property TargetOptions: TConvertOptions read FTargetOptions write FTargetOptions; + property TargetPixelFormat: TPixelFormat index 1 read GetPixelFormat; + property TargetSamplesPerPixel: byte read FTargetSPP write SetTargetSamplesPerPixel; + end; + +function NewColorManager: PColorManager; +function ClampByte(Value: integer): byte; +function MulDiv16(Number,Numerator,Denominator: word): word; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses KolMath; + +type + PCMYK = ^TCMYK; + TCMYK = packed record + C,M,Y,K: byte; + end; + PCMYK16 = ^TCMYK16; + TCMYK16 = packed record + C,M,Y,K: word; + end; + PCMY = ^TCMY; + TCMY = packed record + C,M,Y: byte; + end; + PCMY16 = ^TCMY16; + TCMY16 = packed record + C,M,Y: word; + end; + PRGB = ^TRGB; + TRGB = packed record + R,G,B: byte; + end; + PRGB16 = ^TRGB16; + TRGB16 = packed record + R,G,B: word; + end; + PRGBA = ^TRGBA; + TRGBA = packed record + R,G,B,A: byte; + end; + PRGBA16 = ^TRGBA16; + TRGBA16 = packed record + R,G,B,A: word; + end; + PBGR = ^TBGR; + TBGR = packed record + B,G,R: byte; + end; + PBGR16 = ^TBGR16; + TBGR16 = packed record + B,G,R: word; + end; + PBGRA = ^TBGRA; + TBGRA = packed record + B,G,R,A: byte; + end; + PBGRA16 = ^TBGRA16; + TBGRA16 = packed record + B,G,R,A: word; + end; + +//----------------- helper functions ----------------------------------------------------------------------------------- + +function ClampByte(Value: integer): byte; +// ensures Value is in the range 0..255, values<0 are clamped to 0 and values > 255 are clamped to 255 +asm + OR EAX,EAX + JNS @@positive + XOR EAX,EAX + RET +@@positive: + CMP EAX,255 + JBE @@OK + MOV EAX,255 +@@OK: +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function MulDiv16(Number,Numerator,Denominator: word): word; +// faster equivalent to Windows' MulDiv function +// Number is passed via AX +// Numerator is passed via DX +// Denominator is passed via CX +// Result is passed via AX +// Note: No error checking takes place. Denominator must be > 0! +asm + MUL DX + DIV CX +end; + +//----------------- TColorManager -------------------------------------------------------------------------------------- + +function NewColorManager: PColorManager; +// set some default values +begin + New(Result,Create); + Result.FSourceBPS:=8; + Result.FTargetBPS:=8; + Result.FSourceSPP:=3; // 24 bit format + Result.FTargetSPP:=3; // 24 bit format + Result.SetGamma(1,DefaultDisplayGamma); + Result.FSourceScheme:=csRGB; + Result.FTargetScheme:=csBGR; + // defaults are from CCIR Recommendation 601-1 + Result.FYCbCrCoefficients[0]:=0.299; + Result.FYCbCrCoefficients[1]:=0.587; + Result.FYCbCrCoefficients[2]:=0.114; + Result.FHSubSampling:=1; + Result.FVSubSampling:=1; + Result.FChanged:=True; +end; + +//----------------- low level conversion routines ---------------------------------------------------------------------- + +// These routines are used for conversions from 16 to 8 bit values, either with gamma correction or byte swap (or both). + +function TColorManager.ComponentNoConvert8(Value: byte): byte; +begin + Result:=Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentNoConvert16(Value: word): word; +begin + Result:=Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentGammaConvert(Value: byte): byte; +begin + Result:=FGammaTable[Value]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentScaleConvert(Value: word): byte; +begin + Result:=MulDiv16(Value,255,65535); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentScaleGammaConvert(Value: word): byte; +begin + Result:=FGammaTable[MulDiv16(Value,255,65535)]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentSwapScaleGammaConvert(Value: word): byte; +begin + Result:=FGammaTable[MulDiv16(System.Swap(Value),255,65535)]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentSwapScaleConvert(Value: word): byte; +begin + Result:=MulDiv16(System.Swap(Value),255,65535); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.ComponentSwapConvert(Value: word): word; +begin + Result:=System.Swap(Value); +end; + +//----------------- row conversion routines ---------------------------------------------------------------------------- + +// Notes: Each method takes parameters for source and target data as well as the count of pixels to work on. This count +// determines the number of pixels in the target buffer. The actual source count may differ for special color +// schemes (like YCbCr) or interlaced lines. +// Mask is a parameter which determines (in a repeative manner) which source pixel should actually be transferred +// to the target buffer. A 1 in the corresponding bit (MSB is leftmost pixel) causes the transfer to happen. +// Usually, this parameter is $FF to transfer all pixels, but for interlaced images (e.g. as in PNG format) +// this will differ to limit pixel transfers. The bit mask only describes which target pixel is to skip. Source +// pixel must be packed. +// Windows DIBs are always byte aligned, so we don't need checks for byte alignments (in target). + +procedure TColorManager.RowConvertBGR2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// same as ConvertBGR2RGB but for BGR target schemes +var + SourceR16,SourceG16,SourceB16,SourceA16: PWord; + SourceR8,SourceG8,SourceB8,SourceA8: PByte; + TargetRun16: PBGR16; + TargetRunA16: PBGRA16; + TargetRun8: PBGR; + TargetRunA8: PBGRA; + BitRun: byte; + Convert8_8: function(Value: byte): byte of object; + Convert16_8: function(Value: word): byte of object; + Convert16_8Alpha: function(Value: word): byte of object; + Convert16_16: function(Value: word): word of object; + SourceIncrement,TargetIncrement: cardinal; + CopyAlpha: boolean; +begin + BitRun:=$80; + // determine alpha handling once + CopyAlpha:=False; + if coAlpha in FSourceOptions then + begin + SourceIncrement:=sizeof(TRGBA); + TargetIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then CopyAlpha:=True; + end + else + begin + SourceIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then TargetIncrement:=sizeof(TRGBA) else TargetIncrement:=sizeof(TRGB); + end; + // in planar mode source increment is always 1 + if Length(Source)>1 then SourceIncrement:=1; + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + // interleaved mode + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + case FTargetBPS of + 8: begin // 888 to 888 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert8_8(SourceR8^); + TargetRunA8.G:=Convert8_8(SourceG8^); + TargetRunA8.B:=Convert8_8(SourceB8^); + // alpha values are never gamma corrected + TargetRunA8.A:=SourceA8^; + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert8_8(SourceR8^); + TargetRun8.G:=Convert8_8(SourceG8^); + TargetRun8.B:=Convert8_8(SourceB8^); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 888 to 161616 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRunA16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRunA16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + TargetRunA16.A:=Convert16_16(MulDiv16(SourceA8^,65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRun16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRun16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Pword(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleGammaConvert else Convert16_8:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleConvert else Convert16_8:=ComponentScaleConvert; + end; + // since alpha channels are never gamma corrected we need a separate conversion routine + if coNeedbyteSwap in FSourceOptions then Convert16_8Alpha:=ComponentSwapScaleConvert else Convert16_8Alpha:=ComponentScaleConvert; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert16_8(SourceR16^); + TargetRunA8.G:=Convert16_8(SourceG16^); + TargetRunA8.B:=Convert16_8(SourceB16^); + TargetRunA8.A:=Convert16_8Alpha(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert16_8(SourceR16^); + TargetRun8.G:=Convert16_8(SourceG16^); + TargetRun8.B:=Convert16_8(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Pbyte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 161616 to 161616 + // no gamma correction for 16 bit samples yet + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(SourceR16^); + TargetRunA16.G:=Convert16_16(SourceG16^); + TargetRunA16.B:=Convert16_16(SourceB16^); + TargetRunA16.A:=Convert16_16(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(SourceR16^); + TargetRun16.G:=Convert16_16(SourceG16^); + TargetRun16.B:=Convert16_16(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertBGR2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// Converts BGR source schemes to RGB target schemes and takes care for byte swapping, alpha copy/skip and +// gamma correction. +var SourceR16,SourceG16,SourceB16,SourceA16: PWord; + SourceR8,SourceG8,SourceB8,SourceA8: PByte; + TargetRun16: PRGB16; + TargetRunA16: PRGBA16; + TargetRun8: PRGB; + TargetRunA8: PRGBA; + BitRun: byte; + Convert8_8: function(Value: byte): byte of object; + Convert16_8: function(Value: word): byte of object; + Convert16_8Alpha: function(Value: word): byte of object; + Convert16_16: function(Value: word): word of object; + SourceIncrement,TargetIncrement: cardinal; + CopyAlpha: boolean; +begin + BitRun:=$80; + // determine alpha handling once + CopyAlpha:=False; + if coAlpha in FSourceOptions then + begin + SourceIncrement:=SizeOf(TRGBA); + TargetIncrement:=SizeOf(TRGB); + if coAlpha in FTargetOptions then CopyAlpha:=True; + end + else + begin + SourceIncrement:=SizeOf(TRGB); + if coAlpha in FTargetOptions then TargetIncrement:=sizeof(TRGBA) else TargetIncrement:=sizeof(TRGB); + end; + // in planar mode source increment is always 1 + if Length(Source)>1 then SourceIncrement:=1; + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + // interleaved mode + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + case FTargetBPS of + 8: begin // 888 to 888 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert8_8(SourceR8^); + TargetRunA8.G:=Convert8_8(SourceG8^); + TargetRunA8.B:=Convert8_8(SourceB8^); + // alpha values are never gamma corrected + TargetRunA8.A:=SourceA8^; + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert8_8(SourceR8^); + TargetRun8.G:=Convert8_8(SourceG8^); + TargetRun8.B:=Convert8_8(SourceB8^); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 888 to 161616 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRunA16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRunA16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + TargetRunA16.A:=Convert16_16(MulDiv16(SourceA8^,65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^), 65535, 255)); + TargetRun16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^), 65535, 255)); + TargetRun16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^), 65535, 255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleGammaConvert else Convert16_8:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleConvert else Convert16_8:=ComponentScaleConvert; + end; + // since alpha channels are never gamma corrected we need a separate conversion routine + if coNeedbyteSwap in FSourceOptions then Convert16_8Alpha:=ComponentSwapScaleConvert else Convert16_8Alpha:=ComponentScaleConvert; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert16_8(SourceR16^); + TargetRunA8.G:=Convert16_8(SourceG16^); + TargetRunA8.B:=Convert16_8(SourceB16^); + TargetRunA8.A:=Convert16_8Alpha(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert16_8(SourceR16^); + TargetRun8.G:=Convert16_8(SourceG16^); + TargetRun8.B:=Convert16_8(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 161616 to 161616 + // no gamma correction for 16 bit samples yet + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(SourceR16^); + TargetRunA16.G:=Convert16_16(SourceG16^); + TargetRunA16.B:=Convert16_16(SourceB16^); + TargetRunA16.A:=Convert16_16(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(SourceR16^); + TargetRun16.G:=Convert16_16(SourceG16^); + TargetRun16.B:=Convert16_16(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertCIELAB2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// conversion of the CIE L*a*b color space to BGR using a two way approach assuming a D65 white point, +// first a conversion to CIE XYZ is performed and then from there to RGB +var LRun8,aRun8,bRun8: PByte; + LRun16,aRun16,bRun16: PWord; + L,A,B,X,Y,Z, // color values in float format + T, + YYn3: extended; // intermediate results + Target8: PByte; + Target16: PWord; + Increment,AlphaSkip: integer; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + LRun8:=Source[0]; + aRun8:=LRun8; + Inc(aRun8); + bRun8:=aRun8; + Inc(bRun8); + Increment:=3; + end + else + begin + LRun8:=Source[0]; + aRun8:=Source[1]; + bRun8:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin /// 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun8^/2.55 else L:=LRun8^; + Inc(LRun8, Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun8^-128; + Inc(aRun8,Increment); + B:=bRun8^-128; + Inc(bRun8,Increment); + end + else + begin + A:=ShortInt(aRun8^); + Inc(aRun8,Increment); + B:=ShortInt(bRun8^); + Inc(bRun8,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // once we have CIE XYZ it is easy (yet quite expensive) + // to calculate RGB values from this + // blue + Target8^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target8); + // green + Target8^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target8); + // red + Target8^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun8^/2.55 else L:=LRun8^; + Inc(LRun8,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun8^-128; + Inc(aRun8,Increment); + B:=bRun8^-128; + Inc(bRun8,Increment); + end + else + begin + A:=ShortInt(aRun8^); + Inc(aRun8,Increment); + B:=ShortInt(bRun8^); + Inc(bRun8,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // blue + Target16^:=MulDiv16(ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))),65535,255); + Inc(Target16); + // red + Target16^:=MulDiv16(ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))),65535,255); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + LRun16:=Source[0]; + aRun16:=LRun16; + Inc(aRun16); + bRun16:=aRun16; + Inc(bRun16); + Increment:=3; + end + else + begin + LRun16:=Source[0]; + aRun16:=Source[1]; + bRun16:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun16^/2.55 else L:=LRun16^; + Inc(LRun16,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun16^-128; + Inc(aRun16,Increment); + B:=bRun16^-128; + Inc(bRun16,Increment); + end + else + begin + A:=ShortInt(aRun16^); + Inc(aRun16, Increment); + B:=ShortInt(bRun16^); + Inc(bRun16, Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // blue + Target8^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target8); + // green + Target8^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target8); + // red + Target8^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun16^/2.55 else L:=LRun16^; + Inc(LRun16,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun16^-128; + Inc(aRun16,Increment); + B:=bRun16^-128; + Inc(bRun16,Increment); + end + else + begin + A:=ShortInt(aRun16^); + Inc(aRun16,Increment); + B:=ShortInt(bRun16^); + Inc(bRun16,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // blue + Target16^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target16); + // green + Target16^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target16); + // red + Target16^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertCIELAB2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// just like RowConvertCIELAB2BGR but for RGB target schemes +var LRun8,aRun8,bRun8: PByte; + LRun16,aRun16,bRun16: PWord; + L,A,B,X,Y,Z, // color values in float format + T,YYn3: extended; // intermediate results + Target8: PByte; + Target16: PWord; + Increment,AlphaSkip: integer; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + LRun8:=Source[0]; + aRun8:=LRun8; + Inc(aRun8); + bRun8:=aRun8; + Inc(bRun8); + Increment:=3; + end + else + begin + LRun8:=Source[0]; + aRun8:=Source[1]; + bRun8:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun8^/2.55 else L:=LRun8^; + Inc(LRun8,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun8^-128; + Inc(aRun8,Increment); + B:=bRun8^-128; + Inc(bRun8,Increment); + end + else + begin + A:=ShortInt(aRun8^); + Inc(aRun8,Increment); + B:=ShortInt(bRun8^); + Inc(bRun8,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // once we have CIE XYZ it is easy (yet quite expensive) to calculate RGB values from this + // red + Target8^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target8); + // green + Target8^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target8); + // blue + Target8^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun8^/2.55 else L:=LRun8^; + Inc(LRun8,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun8^-128; + Inc(aRun8,Increment); + B:=bRun8^-128; + Inc(bRun8,Increment); + end + else + begin + A:=ShortInt(aRun8^); + Inc(aRun8,Increment); + B:=ShortInt(bRun8^); + Inc(bRun8,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // red + Target16^:=MulDiv16(Clampbyte(Round(255*(2.998*X-1.458*Y-0.541*Z))),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(Clampbyte(Round(255*(-0.952*X+1.893*Y+0.059*Z))),65535,255); + Inc(Target16); + // blue + Target16^:=MulDiv16(Clampbyte(Round(255*(0.099*X-0.198*Y+1.099*Z))),65535,255); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + LRun16:=Source[0]; + aRun16:=LRun16; + Inc(aRun16); + bRun16:=aRun16; + Inc(bRun16); + Increment:=3; + end + else + begin + LRun16:=Source[0]; + aRun16:=Source[1]; + bRun16:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun16^/2.55 else L:=LRun16^; + Inc(LRun16,Increment); + if coLabChromaOffset in FSourceOptions then + begin + A:=aRun16^-128; + Inc(aRun16,Increment); + B:=bRun16^-128; + Inc(bRun16,Increment); + end + else + begin + A:=ShortInt(aRun16^); + Inc(aRun16,Increment); + B:=ShortInt(bRun16^); + Inc(bRun16,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // red + Target8^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target8); + // green + Target8^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target8); + // blue + Target8^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coLabbyteRange in FSourceOptions then L:=LRun16^/2.55 else L:=LRun16^; + Inc(LRun16,Increment); + if coLabChromaOffset in FSourceOptions then + begin + a:=aRun16^-128; + Inc(aRun16,Increment); + b:=bRun16^-128; + Inc(bRun16,Increment); + end + else + begin + a:=ShortInt(aRun16^); + Inc(aRun16,Increment); + b:=ShortInt(bRun16^); + Inc(bRun16,Increment); + end; + YYn3:=(L+16)/116; // this corresponds to (Y/Yn)^1/3 + if L<7.9996 then + begin + Y:=L/903.3; + X:=A/3893.5+Y; + Z:=Y-B/1557.4; + end + else + begin + T:=YYn3+A/500; + X:=T*T*T; + Y:=YYn3*YYn3*YYn3; + T:=YYn3-B/200; + Z:=T*T*T; + end; + // red + Target16^:=ClampByte(Round(255*(2.998*X-1.458*Y-0.541*Z))); + Inc(Target16); + // green + Target16^:=ClampByte(Round(255*(-0.952*X+1.893*Y+0.059*Z))); + Inc(Target16); + // blue + Target16^:=ClampByte(Round(255*(0.099*X-0.198*Y+1.099*Z))); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertCMYK2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// converts a stream of Count CMYK values to BGR +var C8,M8,Y8,K8: PByte; + C16,M16,Y16,K16: PWord; + Target8: PByte; + Target16: PWord; + Increment,AlphaSkip: integer; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=4 then + begin + // plane mode + C8:=Source[0]; + M8:=Source[1]; + Y8:=Source[2]; + K8:=Source[3]; + Increment:=1; + end + else + begin + // interleaved mode + C8:=Source[0]; + M8:=C8; + Inc(M8); + Y8:=M8; + Inc(Y8); + K8:=Y8; + Inc(K8); + Increment:=4; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // blue + Target8^:=ClampByte(255-(Y8^-MulDiv16(Y8^,K8^,255)+K8^)); + Inc(Target8); + // green + Target8^:=ClampByte(255-(M8^-MulDiv16(M8^,K8^,255)+K8^)); + Inc(Target8); + // blue + Target8^:=ClampByte(255-(C8^-MulDiv16(C8^,K8^,255)+K8^)); + Inc(Target8,1+AlphaSkip); + Inc(C8,Increment); + Inc(M8,Increment); + Inc(Y8,Increment); + Inc(K8,Increment); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count > 0 do + begin + if Boolean(Mask and BitRun) then + begin + // blue + Target16^:=MulDiv16(Clampbyte(255-(Y8^-MulDiv16(Y8^,K8^,255)+K8^)),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(Clampbyte(255-(M8^-MulDiv16(M8^,K8^,255)+K8^)),65535,255); + Inc(Target16); + // blue + Target16^:=MulDiv16(Clampbyte(255-(C8^-MulDiv16(C8^,K8^,255)+K8^)),65535,255); + Inc(Target16,1+AlphaSkip); + Inc(C8,Increment); + Inc(M8,Increment); + Inc(Y8,Increment); + Inc(K8,Increment); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=4 then + begin + // plane mode + C16:=Source[0]; + M16:=Source[1]; + Y16:=Source[2]; + K16:=Source[3]; + Increment:=1; + end + else + begin + // interleaved mode + C16:=Source[0]; + M16:=C16; + Inc(M16); + Y16:=M16; + Inc(Y16); + K16:=Y16; + Inc(K16); + Increment:=4; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // blue + Target8^:=ClampByte(255-MulDiv16((Y16^-MulDiv16(Y16^,K16^,65535)+K16^),255,65535)); + Inc(Target8); + // green + Target8^:=ClampByte(255-MulDiv16((M16^-MulDiv16(M16^,K16^,65535)+K16^),255,65535)); + Inc(Target8); + // blue + Target8^:=ClampByte(255-MulDiv16((C16^-MulDiv16(C16^,K16^,65535)+K16^),255,65535)); + Inc(Target8,1+AlphaSkip); + Inc(C16,Increment); + Inc(M16,Increment); + Inc(Y16,Increment); + Inc(K16,Increment); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // blue + Target16^:=65535-(Y16^-MulDiv16(Y16^,K16^,65535)+K16^); + Inc(Target16); + // green + Target16^:=65535-(M16^-MulDiv16(M16^,K16^,65535)+K16^); + Inc(Target16); + // blue + Target16^:=65535-(C16^-MulDiv16(C16^,K16^,65535)+K16^); + Inc(Target16,1+AlphaSkip); + Inc(C16,Increment); + Inc(M16,Increment); + Inc(Y16,Increment); + Inc(K16,Increment); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertCMYK2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// converts a stream of Count CMYK values to RGB, +var C8,M8,Y8,K8: PByte; + C16,M16,Y16,K16: PWord; + Target8: PByte; + Target16: PWord; + Increment,AlphaSkip: integer; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=4 then + begin + // plane mode + C8:=Source[0]; + M8:=Source[1]; + Y8:=Source[2]; + K8:=Source[3]; + Increment:=1; + end + else + begin + // interleaved mode + C8:=Source[0]; + M8:=C8; + Inc(M8); + Y8:=M8; + Inc(Y8); + K8:=Y8; + Inc(K8); + Increment:=4; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count > 0 do + begin + if Boolean(Mask and BitRun) then + begin + // red + Target8^:=ClampByte(255-(C8^-MulDiv16(C8^,K8^,255)+K8^)); + Inc(Target8); + // green + Target8^:=ClampByte(255-(M8^-MulDiv16(M8^,K8^,255)+K8^)); + Inc(Target8); + // blue + Target8^:=ClampByte(255-(Y8^-MulDiv16(Y8^,K8^,255)+K8^)); + Inc(Target8,1+AlphaSkip); + Inc(C8,Increment); + Inc(M8,Increment); + Inc(Y8,Increment); + Inc(K8,Increment); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count > 0 do + begin + if Boolean(Mask and BitRun) then + begin + // red + Target16^:=MulDiv16(ClampByte(255-(C8^-MulDiv16(C8^,K8^,255)+K8^)),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(ClampByte(255-(M8^-MulDiv16(M8^,K8^,255)+K8^)),65535,255); + Inc(Target16); + // blue + Target16^:=MulDiv16(ClampByte(255-(Y8^-MulDiv16(Y8^,K8^,255)+K8^)),65535,255); + Inc(Target16,1+AlphaSkip); + Inc(C8,Increment); + Inc(M8,Increment); + Inc(Y8,Increment); + Inc(K8,Increment); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=4 then + begin + // plane mode + C16:=Source[0]; + M16:=Source[1]; + Y16:=Source[2]; + K16:=Source[3]; + Increment:=1; + end + else + begin + // interleaved mode + C16:=Source[0]; + M16:=C16; + Inc(M16); + Y16:=M16; + Inc(Y16); + K16:=Y16; + Inc(K16); + Increment:=4; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // red + Target8^:=ClampByte(255-MulDiv16((C16^-MulDiv16(C16^,K16^,65535)+K16^),255,65535)); + Inc(Target8); + // green + Target8^:=ClampByte(255-MulDiv16((M16^-MulDiv16(M16^,K16^,65535)+K16^),255,65535)); + Inc(Target8); + // blue + Target8^:=ClampByte(255-MulDiv16((Y16^-MulDiv16(Y16^,K16^,65535)+K16^),255,65535)); + Inc(Target8,1+AlphaSkip); + Inc(C16,Increment); + Inc(M16,Increment); + Inc(Y16,Increment); + Inc(K16,Increment); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // red + Target16^:=65535-(C16^-MulDiv16(C16^,K16^,65535)+K16^); + Inc(Target16); + // green + Target16^:=65535-(M16^-MulDiv16(M16^,K16^,65535)+K16^); + Inc(Target16); + // blue + Target16^:=65535-(Y16^-MulDiv16(Y16^,K16^,65535)+K16^); + Inc(Target16,1+AlphaSkip); + Inc(C16,Increment); + Inc(M16,Increment); + Inc(Y16,Increment); + Inc(K16,Increment); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertGray(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// conversion from source grayscale (possibly with alpha) to target grayscale +// Note: Since grayscale is basically handled like indexed mode (palette), there is no need to +// handle gamma correction here as this happend already during palette creation. +var Target8: PByte; + Target16: PWord; + Source8: PByte; + Source16: PWord; + BitRun: byte; + AlphaSkip: integer; + Convert16: function(Value: word): byte of object; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FSourceOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: case FTargetBPS of + 8: begin // 888 to 888 + Source8:=Source[0]; + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Target8^:=Source8^; + Inc(Source8,1+AlphaSkip); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Target8); + end; + end; + 16: begin // 888 to 161616 + Source8:=Source[0]; + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Target16^:=MulDiv16(Source8^,65535,255); + Inc(Source8,1+AlphaSkip); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Target16); + end; + end; + end; + 16: case FTargetBPS of + 8: begin // 161616 to 888 + Source16:=Source[0]; + Target8:=Target; + if coNeedbyteSwap in FSourceOptions then Convert16:=ComponentSwapScaleConvert else Convert16:=ComponentScaleConvert; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Target8^:=Convert16(Source16^); + Inc(Source16,1+AlphaSkip); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Target8); + end; + end; + 16: begin // 161616 to 161616 + Source16:=Source[0]; + Target16:=Target; + if coNeedbyteSwap in FSourceOptions then + begin + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Target16^:=System.Swap(Source16^); + Inc(Source16,1+AlphaSkip); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Target16); + end; + end + else + begin + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Target16^:=Source16^; + Inc(Source16,1+AlphaSkip); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Target16); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertIndexed8(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// This is the core conversion routine for indexed pixel formats. +// This routine takes care about sample scaling and interlacing. +// Note: 16 bit indexed mode is a bit different (words instead bytes and byte swap) and handled separately. +var SourceRun,TargetRun: PByte; + Value,BitRun,TargetMask,SourceMask,SourceShift,TargetShift,MaxInSample, + MaxOutSample,SourceBPS, // local copies to ease assembler access + TargetBPS: byte; + Done: cardinal; +begin + SourceRun:=Source[0]; + TargetRun:=Target; + if (FSourceBPS=FTargetBPS) and (Mask=$FF) then Move(SourceRun^,TargetRun^,(Count*FSourceBPS+7) div 8) else + begin + BitRun:=$80; + // make a copy of these both values from private variables to local variables + // to ease access during assembler parts in the code + SourceBPS:=FSourceBPS; + TargetBPS:=FTargetBPS; + SourceMask:=byte(not ((1 shl (8-SourceBPS))-1)); + MaxInSample:=(1 shl SourceBPS)-1; + TargetMask:=(1 shl (8-TargetBPS))-1; + MaxOutSample:=(1 shl TargetBPS)-1; + SourceShift:=8; + TargetShift:=8-TargetBPS; + Done:=0; + while Done0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun^:=System.Swap(SourceRun^); + Inc(SourceRun); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRun); + end; + end + else + begin + if Mask=$FF then Move(SourceRun^,TargetRun^,2*Count) else + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun^:=SourceRun^; + Inc(SourceRun); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRun); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertIndexedSource16(Source: array of Pointer; Target: Pointer; Count: Cardinal; Mask: byte); +// This is the core conversion routine for indexed pixel formats with 16 bits per source sample values involved. +var TargetRun8: PByte; + SourceRun16: PWord; + Value,BitRun,TargetMask,TargetShift,MaxOutSample, + TargetBPS: byte; // local copies to ease assembler access +begin + SourceRun16:=Source[0]; + TargetRun8:=Target; + BitRun:=$80; + // make a copy of these both values from private variables to local variables + // to ease access during assembler parts in the code + TargetBPS:=FTargetBPS; + TargetMask:=(1 shl (8-TargetBPS))-1; + MaxOutSample:=(1 shl TargetBPS)-1; + TargetShift:=8-TargetBPS; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + if coNeedbyteSwap in FSourceOptions then Value:=MulDiv16(System.Swap(SourceRun16^),MaxOutSample,65535) else Value:=MulDiv16(SourceRun16^,MaxOutSample,65535); + TargetRun8^:=(TargetRun8^ and TargetMask) or (Value shl TargetShift); + Inc(SourceRun16); + end; + asm + ROR byte PTR [BitRun],1 // adjust test bit mask + MOV CL,[TargetBPS] + ROR byte PTR [TargetMask],CL // roll target mask with target bit count + end; + if TargetShift=0 then TargetShift:=8-TargetBPS else Dec(TargetShift,TargetBPS); + Dec(Count); + // advance target pointer every (8 div target bit count) + if (Count mod (8 div TargetBPS))=0 then Inc(TargetRun8); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertIndexedTarget16(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// This is the core conversion routine for indexed pixel formats with 16 bits per target sample values involved. +var SourceRun8: PByte; + TargetRun16: PWord; + Value: word; + BitRun,SourceMask,SourceShift,MaxInSample,SourceBPS: byte; +begin + SourceRun8:=Source[0]; + TargetRun16:=Target; + BitRun:=$80; + SourceBPS:=FSourceBPS; + SourceMask:=byte(not ((1 shl (8-SourceBPS))-1)); + MaxInSample:=(1 shl SourceBPS)-1; + SourceShift:=8; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + // adjust shift value by source bit depth + Dec(SourceShift,SourceBPS); + Value:=(SourceRun8^ and SourceMask) shr SourceShift; + Value:=MulDiv16(Value,65535,MaxInSample); + if coNeedbyteSwap in FSourceOptions then TargetRun16^:=System.Swap(Value) else TargetRun16^:=Value; + if SourceShift=0 then + begin + SourceShift:=8; + Inc(SourceRun8); + end; + asm + MOV CL,[SourceBPS] + ROR byte PTR [SourceMask],CL // roll source bit mask with source bit count + end; + end; + asm + ROR byte PTR [BitRun],1 // adjust test bit mask + end; + Dec(Count); + // advance target pointer every (8 div target bit count) + Inc(TargetRun16); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertRGB2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// Converts RGB source schemes to BGR target schemes and takes care for byte swapping, alpha copy/skip and +// gamma correction. +var SourceR16,SourceG16,SourceB16,SourceA16: PWord; + SourceR8,SourceG8,SourceB8,SourceA8: PByte; + TargetRun16: PBGR16; + TargetRunA16: PBGRA16; + TargetRun8: PBGR; + TargetRunA8: PBGRA; + BitRun: byte; + Convert8_8: function(Value: byte): byte of object; + Convert16_8: function(Value: word): byte of object; + Convert16_8Alpha: function(Value: word): byte of object; + Convert16_16: function(Value: word): word of object; + SourceIncrement,TargetIncrement: cardinal; + CopyAlpha: boolean; +begin + BitRun:=$80; + // determine alpha handling once + CopyAlpha:=False; + if coAlpha in FSourceOptions then + begin + // byte size of components doesn't matter as the increments are applied to + // pointers whose data types determine the final increment + SourceIncrement:=sizeof(TRGBA); + TargetIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then CopyAlpha:=True; + end + else + begin + SourceIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then TargetIncrement:=sizeof(TRGBA) else TargetIncrement:=sizeof(TRGB); + end; + // in planar mode source increment is always 1 + if Length(Source)>1 then SourceIncrement:=1; + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + // interleaved mode + SourceR8:=Source[0]; + SourceG8:=SourceR8; + Inc(SourceG8); + SourceB8:=SourceG8; + Inc(SourceB8); + SourceA8:=SourceB8; + Inc(SourceA8); + end + else + begin + SourceR8:=Source[0]; + SourceG8:=Source[1]; + SourceB8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + case FTargetBPS of + 8: begin // 888 to 888 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert8_8(SourceR8^); + TargetRunA8.G:=Convert8_8(SourceG8^); + TargetRunA8.B:=Convert8_8(SourceB8^); + // alpha values are never gamma corrected + TargetRunA8.A:=SourceA8^; + Inc(SourceB8, SourceIncrement); + Inc(SourceG8, SourceIncrement); + Inc(SourceR8, SourceIncrement); + Inc(SourceA8, SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert8_8(SourceR8^); + TargetRun8.G:=Convert8_8(SourceG8^); + TargetRun8.B:=Convert8_8(SourceB8^); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 888 to 161616 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRunA16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRunA16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + TargetRunA16.A:=Convert16_16(MulDiv16(SourceA8^,65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRun16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRun16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + SourceR16:=Source[0]; + SourceG16:=SourceR16; + Inc(SourceG16); + SourceB16:=SourceG16; + Inc(SourceB16); + SourceA16:=SourceB16; + Inc(SourceA16); + end + else + begin + SourceR16:=Source[0]; + SourceG16:=Source[1]; + SourceB16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleGammaConvert else Convert16_8:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleConvert else Convert16_8:=ComponentScaleConvert; + end; + // since alpha channels are never gamma corrected we need a separate conversion routine + if coNeedbyteSwap in FSourceOptions then Convert16_8Alpha:=ComponentSwapScaleConvert else Convert16_8Alpha:=ComponentScaleConvert; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert16_8(SourceR16^); + TargetRunA8.G:=Convert16_8(SourceG16^); + TargetRunA8.B:=Convert16_8(SourceB16^); + TargetRunA8.A:=Convert16_8Alpha(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert16_8(SourceR16^); + TargetRun8.G:=Convert16_8(SourceG16^); + TargetRun8.B:=Convert16_8(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(Pbyte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 161616 to 161616 + // no gamma correction for 16 bit samples yet + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(SourceR16^); + TargetRunA16.G:=Convert16_16(SourceG16^); + TargetRunA16.B:=Convert16_16(SourceB16^); + TargetRunA16.A:=Convert16_16(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(SourceR16^); + TargetRun16.G:=Convert16_16(SourceG16^); + TargetRun16.B:=Convert16_16(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertRGB2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// same as ConvertRGB2BGR but for RGB target schemes +var SourceR16,SourceG16,SourceB16,SourceA16: PWord; + SourceR8,SourceG8,SourceB8,SourceA8: PByte; + TargetRun16: PRGB16; + TargetRunA16: PRGBA16; + TargetRun8: PRGB; + TargetRunA8: PRGBA; + BitRun: byte; + Convert8_8: function(Value: byte): byte of object; + Convert16_8: function(Value: word): byte of object; + Convert16_8Alpha: function(Value: word): byte of object; + Convert16_16: function(Value: word): word of object; + SourceIncrement,TargetIncrement: cardinal; + CopyAlpha: boolean; +begin + BitRun:=$80; + // determine alpha handling once + CopyAlpha:=False; + if coAlpha in FSourceOptions then + begin + SourceIncrement:=sizeof(TRGBA); + TargetIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then CopyAlpha:=True; + end + else + begin + SourceIncrement:=sizeof(TRGB); + if coAlpha in FTargetOptions then TargetIncrement:=sizeof(TRGBA) else TargetIncrement:=sizeof(TRGB); + end; + // in planar mode source increment is always 1 + if Length(Source)>1 then SourceIncrement:=1; + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + // interleaved mode + SourceR8:=Source[0]; + SourceG8:=SourceR8; + Inc(SourceG8); + SourceB8:=SourceG8; + Inc(SourceB8); + SourceA8:=SourceB8; + Inc(SourceA8); + end + else + begin + SourceR8:=Source[0]; + SourceG8:=Source[1]; + SourceB8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + case FTargetBPS of + 8: begin // 888 to 888 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert8_8(SourceR8^); + TargetRunA8.G:=Convert8_8(SourceG8^); + TargetRunA8.B:=Convert8_8(SourceB8^); + // alpha values are never gamma corrected + TargetRunA8.A:=SourceA8^; + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert8_8(SourceR8^); + TargetRun8.G:=Convert8_8(SourceG8^); + TargetRun8.B:=Convert8_8(SourceB8^); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 888 to 161616 + if coApplyGamma in FTargetOptions then Convert8_8:=ComponentGammaConvert else Convert8_8:=ComponentNoConvert8; + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB8:=Source[0]; + SourceG8:=SourceB8; + Inc(SourceG8); + SourceR8:=SourceG8; + Inc(SourceR8); + SourceA8:=SourceR8; + Inc(SourceA8); + end + else + begin + SourceB8:=Source[0]; + SourceG8:=Source[1]; + SourceR8:=Source[2]; + if coAlpha in FSourceOptions then SourceA8:=Source[3] else SourceA8:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^),65535,255)); + TargetRunA16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^),65535,255)); + TargetRunA16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^),65535,255)); + TargetRunA16.A:=Convert16_16(MulDiv16(SourceA8^,65535,255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + Inc(SourceA8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(MulDiv16(Convert8_8(SourceR8^), 65535, 255)); + TargetRun16.G:=Convert16_16(MulDiv16(Convert8_8(SourceG8^), 65535, 255)); + TargetRun16.B:=Convert16_16(MulDiv16(Convert8_8(SourceB8^), 65535, 255)); + Inc(SourceB8,SourceIncrement); + Inc(SourceG8,SourceIncrement); + Inc(SourceR8,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + SourceR16:=Source[0]; + SourceG16:=SourceR16; + Inc(SourceG16); + SourceB16:=SourceG16; + Inc(SourceB16); + SourceA16:=SourceB16; + Inc(SourceA16); + end + else + begin + SourceR16:=Source[0]; + SourceG16:=Source[1]; + SourceB16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleGammaConvert else Convert16_8:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16_8:=ComponentSwapScaleConvert else Convert16_8:=ComponentScaleConvert; + end; + // since alpha channels are never gamma corrected we need a separate conversion routine + if coNeedbyteSwap in FSourceOptions then Convert16_8Alpha:=ComponentSwapScaleConvert else Convert16_8Alpha:=ComponentScaleConvert; + if CopyAlpha then + begin + TargetRunA8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA8.R:=Convert16_8(SourceR16^); + TargetRunA8.G:=Convert16_8(SourceG16^); + TargetRunA8.B:=Convert16_8(SourceB16^); + TargetRunA8.A:=Convert16_8Alpha(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA8); + end; + end + else + begin + TargetRun8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun8.R:=Convert16_8(SourceR16^); + TargetRun8.G:=Convert16_8(SourceG16^); + TargetRun8.B:=Convert16_8(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PByte(TargetRun8),TargetIncrement); + end; + end; + end; + 16: begin // 161616 to 161616 + // no gamma correction for 16 bit samples yet + if coNeedbyteSwap in FSourceOptions then Convert16_16:=ComponentSwapConvert else Convert16_16:=ComponentNoConvert16; + if Length(Source)=1 then + begin + SourceB16:=Source[0]; + SourceG16:=SourceB16; + Inc(SourceG16); + SourceR16:=SourceG16; + Inc(SourceR16); + SourceA16:=SourceR16; + Inc(SourceA16); + end + else + begin + SourceB16:=Source[0]; + SourceG16:=Source[1]; + SourceR16:=Source[2]; + if coAlpha in FSourceOptions then SourceA16:=Source[3] else SourceA16:=nil; + end; + if CopyAlpha then + begin + TargetRunA16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRunA16.R:=Convert16_16(SourceR16^); + TargetRunA16.G:=Convert16_16(SourceG16^); + TargetRunA16.B:=Convert16_16(SourceB16^); + TargetRunA16.A:=Convert16_16(SourceA16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + Inc(SourceA16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(TargetRunA16); + end; + end + else + begin + TargetRun16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + TargetRun16.R:=Convert16_16(SourceR16^); + TargetRun16.G:=Convert16_16(SourceG16^); + TargetRun16.B:=Convert16_16(SourceB16^); + Inc(SourceB16,SourceIncrement); + Inc(SourceG16,SourceIncrement); + Inc(SourceR16,SourceIncrement); + end; + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + Inc(PWord(TargetRun16),TargetIncrement); + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertPhotoYCC2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// converts from PhotoYCC format to BGR(A) +var Y,Cb,Cr: integer; + Yf,Cbf,Crf: single; + Y8Run,Cb8Run,Cr8Run: PByte; + Y16Run,Cb16Run,Cr16Run: PWord; + Target8: PByte; + Target16: PWord; + AlphaSkip: integer; + BitRun: byte; + Increment: integer; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + Y8Run:=Source[0]; + Cb8Run:=Y8Run; + Inc(Cb8Run); + Cr8Run:=Cb8Run; + Inc(Cr8Run); + Increment:=3; + end + else + begin + Y8Run:=Source[0]; + Cb8Run:=Source[1]; + Cr8Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // blue + Target16^:=MulDiv16(Clampbyte(Y+FCbToBlueTable[Cb]),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(Clampbyte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]), 65535, 255); + Inc(Target16); + // red + Target16^:=MulDiv16(Clampbyte(Y+FCrToRedTable[Cr]),65535,255); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + Y16Run:=Source[0]; + Cb16Run:=Y16Run; + Inc(Cb16Run); + Cr16Run:=Cb16Run; + Inc(Cr16Run); + Increment:=3; + end + else + begin + Y16Run:=Source[0]; + Cb16Run:=Source[1]; + Cr16Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=MulDiv16(Y16Run^,255,65535); + Inc(Y16Run,Increment); + Cb:=MulDiv16(Cb16Run^,255,65535); + Inc(Cb16Run,Increment); + Cr:=MulDiv16(Cr16Run^,255,65535); + Inc(Cr16Run,Increment); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + // conversion from 16 to 16 is done with full precision, so there is no + // loss of information, but the code is slower because the lookup tables + // cannot be used + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Yf:=1.3584*Y16Run^; + Inc(Y16Run,Increment); + Cbf:=Cb16Run^-40092; // (156*65535) div 255 + Inc(Cb16Run,Increment); + Crf:=Cr16Run^-35209; // (137*65535) div 255 + Inc(Cr16Run,Increment); + // blue + Target16^:=Round(Yf+2.2179*Cbf); + Inc(Target16); + // green + Target16^:=Round(Yf-0.9271435*Crf-0.4302726*Cbf); + Inc(Target16); + // red + Target16^:=Round(Yf+1.8215*Crf); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertPhotoYCC2RGB(Source: array of Pointer; Target: Pointer; Count: Cardinal; Mask: byte); +// converts from PhotoYCC format to RGB(A) +var Y,Cb,Cr,AlphaSkip,Increment: integer; + Yf,Cbf,Crf: single; + Y8Run, Cb8Run, Cr8Run: PByte; + Y16Run, Cb16Run, Cr16Run: PWord; + Target8: PByte; + Target16: PWord; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + Y8Run:=Source[0]; + Cb8Run:=Y8Run; + Inc(Cb8Run); + Cr8Run:=Cb8Run; + Inc(Cr8Run); + Increment:=3; + end + else + begin + Y8Run:=Source[0]; + Cb8Run:=Source[1]; + Cr8Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // red + Target16^:=MulDiv16(ClampByte(Y+FCrToRedTable[Cr]),65535,255); + Inc(Target16,1+AlphaSkip); + // green + Target16^:=MulDiv16(ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]),65535,255); + Inc(Target16); + // blue + Target16^:=MulDiv16(ClampByte(Y+FCbToBlueTable[Cb]),65535,255); + Inc(Target16); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + Y16Run:=Source[0]; + Cb16Run:=Y16Run; + Inc(Cb16Run); + Cr16Run:=Cb16Run; + Inc(Cr16Run); + Increment:=3; + end + else + begin + Y16Run:=Source[0]; + Cb16Run:=Source[1]; + Cr16Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=MulDiv16(Y16Run^,255,65535); + Inc(Y16Run,Increment); + Cb:=MulDiv16(Cb16Run^,255,65535); + Inc(Cb16Run,Increment); + Cr:=MulDiv16(Cr16Run^,255,65535); + Inc(Cr16Run,Increment); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreenTable[Cr]); + Inc(Target8); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + // conversion from 16 to 16 is done with full precision, so there is no + // loss of information, but the code is slower because the lookup tables + // cannot be used + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Yf:=1.3584*Y16Run^; + Inc(Y16Run,Increment); + Cbf:=Cb16Run^-40092; // (156*65535) div 255 + Inc(Cb16Run,Increment); + Crf:=Cr16Run^-35209; // (137*65535) div 255 + Inc(Cr16Run,Increment); + // red + Target16^:=Round(Yf+1.8215*Crf); + Inc(Target16,1+AlphaSkip); + // green + Target16^:=Round(Yf-0.9271435*Crf-0.4302726*Cbf); + Inc(Target16); + // blue + Target16^:=Round(Yf+2.2179*Cbf); + Inc(Target16); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertYCbCr2BGR(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// converts from standard YCbCr to BGR(A) +var Y,Cb,Cr,AlphaSkip,Increment: integer; + Yf,Cbf,Crf: single; + Y8Run,Cb8Run,Cr8Run: PByte; + Y16Run,Cb16Run,Cr16Run: PWord; + Target8: PByte; + Target16: PWord; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + Y8Run:=Source[0]; + Cb8Run:=Y8Run; + Inc(Cb8Run); + Cr8Run:=Cb8Run; + Inc(Cr8Run); + Increment:=3; + end + else + begin + Y8Run:=Source[0]; + Cb8Run:=Source[1]; + Cr8Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // blue + Target16^:=MulDiv16(Clampbyte(Y+FCbToBlueTable[Cb]),65535,255); + Inc(Target16); + // green + Target16^:=MulDiv16(Clampbyte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]),65535,255); + Inc(Target16); + // red + Target16^:=MulDiv16(Clampbyte(Y+FCrToRedTable[Cr]),65535,255); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + Y16Run:=Source[0]; + Cb16Run:=Y16Run; + Inc(Cb16Run); + Cr16Run:=Cb16Run; + Inc(Cr16Run); + Increment:=3; + end + else + begin + Y16Run:=Source[0]; + Cb16Run:=Source[1]; + Cr16Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=MulDiv16(Y16Run^,255,65535); + Inc(Y16Run,Increment); + Cb:=MulDiv16(Cb16Run^,255,65535); + Inc(Cb16Run,Increment); + Cr:=MulDiv16(Cr16Run^,255,65535); + Inc(Cr16Run,Increment); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + // conversion from 16 to 16 is done with full precision, so there is no + // loss of information, but the code is slower because the lookup tables + // cannot be used + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Yf:=1.3584*Y16Run^; + Inc(Y16Run,Increment); + Cbf:=Cb16Run^-40092; // (156*65535) div 255 + Inc(Cb16Run,Increment); + Crf:=Cr16Run^-35209; // (137*65535) div 255 + Inc(Cr16Run,Increment); + // blue + Target16^:=Round(Yf+2.2179*Cbf); + Inc(Target16); + // green + Target16^:=Round(Yf-0.9271435*Crf-0.4302726*Cbf); + Inc(Target16); + // red + Target16^:=Round(Yf+1.8215*Crf); + Inc(Target16,1+AlphaSkip); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.RowConvertYCbCr2RGB(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// converts from standard YCbCr to RGB(A) +var Y,Cb,Cr,AlphaSkip,Increment: integer; + Yf,Cbf,Crf: single; + Y8Run,Cb8Run,Cr8Run: PByte; + Y16Run,Cb16Run,Cr16Run: PWord; + Target8: PByte; + Target16: PWord; + BitRun: byte; +begin + BitRun:=$80; + AlphaSkip:=Ord(coAlpha in FTargetOptions); // 0 if no alpha must be skipped, otherwise 1 + case FSourceBPS of + 8: begin + if Length(Source)=1 then + begin + Y8Run:=Source[0]; + Cb8Run:=Y8Run; + Inc(Cb8Run); + Cr8Run:=Cb8Run; + Inc(Cr8Run); + Increment:=3; + end + else + begin + Y8Run:=Source[0]; + Cb8Run:=Source[1]; + Cr8Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 888 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // red + Target8^:=ClampByte(Y+FCrToRedTable[Cr]); + Inc(Target8,1+AlphaSkip); + // green + Target8^:=ClampByte(Y+FCbToGreenTable[Cb]+FCrToGreenTable[Cr]); + Inc(Target8); + // blue + Target8^:=ClampByte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + end + else Inc(Target8,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 888 to 161616 + Target16:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=Y8Run^; + Inc(Y8Run,Increment); + Cb:=Cb8Run^; + Inc(Cb8Run,Increment); + Cr:=Cr8Run^; + Inc(Cr8Run,Increment); + // red + Target16^:=MulDiv16(Clampbyte(Y+FCrToRedTable[Cr]),65535,255); + Inc(Target16, 1+AlphaSkip); + // green + Target16^:=MulDiv16(Clampbyte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]), 65535, 255); + Inc(Target16); + // blue + Target16^:=MulDiv16(Clampbyte(Y+FCbToBlueTable[Cb]),65535,255); + Inc(Target16); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + 16: begin + if Length(Source)=1 then + begin + Y16Run:=Source[0]; + Cb16Run:=Y16Run; Inc(Cb16Run); + Cr16Run:=Cb16Run; Inc(Cr16Run); + Increment:=3; + end + else + begin + Y16Run:=Source[0]; + Cb16Run:=Source[1]; + Cr16Run:=Source[2]; + Increment:=1; + end; + case FTargetBPS of + 8: begin // 161616 to 888 + Target8:=Target; + while Count>0 do + begin + if Boolean(Mask and BitRun) then + begin + Y:=MulDiv16(Y16Run^, 255, 65535); + Inc(Y16Run, Increment); + Cb:=MulDiv16(Cb16Run^, 255, 65535); + Inc(Cb16Run, Increment); + Cr:=MulDiv16(Cr16Run^, 255, 65535); + Inc(Cr16Run, Increment); + // red + Target8^:=Clampbyte(Y+FCrToRedTable[Cr]); + Inc(Target8, 1+AlphaSkip); + // green + Target8^:=Clampbyte(Y+FCbToGreenTable[Cb]+FCrToGreentable[Cr]); + Inc(Target8); + // blue + Target8^:=Clampbyte(Y+FCbToBlueTable[Cb]); + Inc(Target8); + end + else Inc(Target8, 3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + 16: begin // 161616 to 161616 + Target16:=Target; + // conversion from 16 to 16 is done with full precision, so there is no + // loss of information, but the code is slower because the lookup tables + // cannot be used + while Count > 0 do + begin + if Boolean(Mask and BitRun) then + begin + Yf:=1.3584*Y16Run^; + Inc(Y16Run,Increment); + Cbf:=Cb16Run^-40092; // (156*65535) div 255 + Inc(Cb16Run,Increment); + Crf:=Cr16Run^-35209; // (137*65535) div 255 + Inc(Cr16Run,Increment); + // red + Target16^:=Round(Yf+1.8215*Crf); + Inc(Target16,1+AlphaSkip); + // green + Target16^:=Round(Yf-0.9271435*Crf-0.4302726*Cbf); + Inc(Target16); + // blue + Target16^:=Round(Yf+2.2179*Cbf); + Inc(Target16); + end + else Inc(Target16,3+AlphaSkip); + asm + ROR byte PTR [BitRun],1 + end; + Dec(Count); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.CreateYCbCrLookup; +// In order to speedup YCbCr conversion lookup tables are used, this methods creates them. +// R:=Y+Cr*(2-2*LumaRed); +// B:=Y+Cb*(2-2*LumaBlue); +// G:=Y-LumaBlue*Cb*(2-2*LumaBlue) / LumaGreen +// -LumaRed*Cr*(2-2*LumaRed) / LumaGreen; +// +// To avoid floating point arithmetic the fractional constants that come out of the equations are represented +// as fixed point values in the range 0...2^16. We also eliminate multiplications by // pre-calculating possible +// values indexed by Cb and Cr (this code assumes conversion is being done for 8-bit samples). +// +// Note: the color manager uses dynamic arrays so the memory used here is automatically freed. +// +// Needed settings: +//-YCbCr parameters must be set or default values are used +var F1,F2,F3,F4: single; + LumaRed,LumaGreen,LumaBlue: single; + I,Offset1,Offset2: integer; +begin + LumaRed:=FYCbCrCoefficients[0]; + LumaGreen:=FYCbCrCoefficients[1]; + LumaBlue:=FYCbCrCoefficients[2]; + F1:=2-2*LumaRed; + F2:=LumaRed*F1/LumaGreen; + F3:=2-2*LumaBlue; + F4:=LumaBlue*F3/LumaGreen; + SetLength(FCrToRedTable,256); + SetLength(FCbToBlueTable,256); + SetLength(FCrToGreenTable,256); + SetLength(FCbToGreenTable,256); + if FSourceScheme=csYCbCr then + begin + // I is the actual input pixel value in the range 0..255, Cb and Cr values are in the range -128..127. + // (for TIFF files they are in a range defined by the ReferenceBlackWhite tag). + Offset1:=-128; + for I:=0 to 255 do + begin + FCrToRedTable[I]:=Round(F1*Offset1); + FCbToBlueTable[I]:=Round(F3*Offset1); + FCrToGreenTable[I]:=-Round(F2*Offset1); + FCbToGreenTable[I]:=-Round(F4*Offset1); + Inc(Offset1); + end; + end + else + begin + // PhotoYCC + // I is the actual input pixel value in the range 0..255, Cb values are in the range -156..99, + // Cr values are in the range -137..118. + // (for TIFF files they are in a range defined by the ReferenceBlackWhite tag). + Offset1:=-156; + Offset2:=-137; + for I:=0 to 255 do + begin + FCrToRedTable[I]:=Round(F1*Offset2); + FCbToBlueTable[I]:=Round(F3*Offset1); + FCrToGreenTable[I]:=-Round(F2*Offset2); + FCbToGreenTable[I]:=-Round(F4*Offset1); + Inc(Offset1); + Inc(Offset2); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TColorManager.GetPixelFormat(Index: integer): TPixelFormat; +// determines the pixel format from the current sample and pixel sizes +// Note: setting pfCustom as pixel format will raise an exception so check the result from this method first +// before you actually assign it to a bitmap. +// +// Needed settings: +//-source samples per pixel and bits per sample for Index = 0 +//-target samples per pixel and bits per sample for Index = 1 +var SamplesPerPixel,BitsPerSample: byte; +begin + case Index of + 0: begin + SamplesPerPixel:=FSourceSPP; + BitsPerSample:=FSourceBPS; + end; + else + SamplesPerPixel:=FTargetSPP; + BitsPerSample:=FTargetBPS; + end; + case SamplesPerPixel of + 1: // one sample per pixel, this is usually a palette format + case BitsPerSample of + 1: Result:=pf1Bit; + 2..4: Result:=pf4bit; // values<4 should be upscaled + 8..16: Result:=pf8bit; // values > 8 bits must be downscaled to 8 bits + else + Result:=pfCustom; + end; + 3: // Typical case is RGB or CIE L*a*b* (565 and 555 16 bit color formats would also be possible, but aren't handled + // by the manager). + case BitsPerSample of + 1..5: Result:=pf15Bit; // values<5 should be upscaled + else + // values > 8 bits should be downscaled + Result:=pf24bit; + end; + 4: // Typical cases: RGBA and CMYK (with 8 bps, other formats like PCX's + // 4 planes with 1 bit must be handled elsewhere) + if BitsPerSample>=8 then Result:=pf32Bit else Result:=pfCustom; + else + Result:=pfCustom; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.PrepareConversion; +// depending on the source and target pixel and color formats a conversion function must be +// determined which actually carries out the conversion +// +// Needed settings: +//-source and target samples per pixel and bits per sample +//-source and target color scheme +begin + FRowConversion:=nil; + // Conversion between indexed and non-indexed formats is not supported as well as + // between source BPS<8 and target BPS > 8. + // csGA and csG (grayscale w and w/o alpha) are considered being indexed modes + if (FSourceScheme in [csIndexed,csG,csGA]) xor (FTargetScheme in [csIndexed,csG]) then Error(14{gesIndexedNotSupported}); + // set up special conversion options + if FSourceScheme in [csGA,csRGBA,csBGRA] then Include(FSourceOptions,coAlpha) else Exclude(FSourceOptions,coAlpha); + if FTargetScheme in [csGA,csRGBA,csBGRA] then Include(FTargetOptions,coAlpha) else Exclude(FTargetOptions,coAlpha); + case FSourceScheme of + csG: if (FSourceBPS=16) or (FTargetBPS=16) then + begin + if (FSourceBPS>=8) and (FTargetBPS>=8) then FRowConversion:=RowConvertGray; + end + else FRowConversion:=RowConvertIndexed8; + csGA: if (FSourceBPS in [8,16]) and (FTargetBPS in [8,16]) then FRowConversion:=RowConvertGray; + csIndexed: + begin + // Grayscale is handled like indexed mode. + // Generally use indexed conversions (with various possible bit operations), + // assign special methods for source only, target only or source and target being 16 bits per sample + if (FSourceBPS=16) and (FTargetBPS=16) then FRowConversion:=RowConvertIndexedBoth16 else + if FSourceBPS=16 then FRowConversion:=RowConvertIndexedSource16 else + if FTargetBPS=16 then FRowConversion:=RowConvertIndexedTarget16 else FRowConversion:=RowConvertIndexed8; + end; + csRGB, + csRGBA: + case FTargetScheme of + csRGB: FRowConversion:=RowConvertRGB2RGB; + csRGBA: FRowConversion:=RowConvertRGB2RGB; + csBGR: FRowConversion:=RowConvertRGB2BGR; + csBGRA: FRowConversion:=RowConvertRGB2BGR; + csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + csBGRA, + csBGR: + case FTargetScheme of + csRGBA: FRowConversion:=RowConvertBGR2RGB; + csBGRA: FRowConversion:=RowConvertBGR2BGR; + csRGB,csBGR,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + csCMY: + case FTargetScheme of + csRGB,csRGBA,csBGR,csBGRA,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + csCMYK: + case FTargetScheme of + csRGBA: FRowConversion:=RowConvertCMYK2RGB; + csBGRA: FRowConversion:=RowConvertCMYK2BGR; + csRGB,csBGR,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + csCIELab: + case FTargetScheme of + csRGBA: FRowConversion:=RowConvertCIELab2RGB; + csBGRA: FRowConversion:=RowConvertCIELab2BGR; + csRGB,csBGR,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + csYCbCr: + begin + // create lookup tables to speed up conversion + CreateYCbCrLookup; + case FTargetScheme of + csRGBA: FRowConversion:=RowConvertYCbCr2RGB; + csBGRA: FRowConversion:=RowConvertYCbCr2BGR; + csRGB,csBGR,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + end; + csPhotoYCC: + begin + // create lookup tables to speed up conversion + CreateYCbCrLookup; + case FTargetScheme of + csRGBA: FRowConversion:=RowConvertPhotoYCC2RGB; + csBGRA: FRowConversion:=RowConvertPhotoYCC2BGR; + csRGB,csBGR,csCMY,csCMYK,csCIELab,csYCbCr: ; + end; + end; + end; + FChanged:=False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetSourceBitsPerSample(const Value: byte); +begin + if not (Value in [1..16]) then Error(16{gesInvalidSampleDepth}); + if FSourceBPS<>Value then + begin + FSourceBPS:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetSourceColorScheme(const Value: TColorScheme); +begin + if FSourceScheme<>Value then + begin + FSourceScheme:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetSourceSamplesPerPixel(const Value: byte); +begin + if not (Value in [1..4]) then Error(17{gesInvalidPixelDepth}); + if FSourceSPP<>Value then + begin + FSourceSPP:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetTargetBitsPerSample(const Value: byte); +begin + if not (Value in [1..16]) then Error(16{gesInvalidSampleDepth}); + if FTargetBPS<>Value then + begin + FTargetBPS:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetTargetColorScheme(const Value: TColorScheme); +begin + if FTargetScheme<>Value then + begin + FTargetScheme:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetTargetSamplesPerPixel(const Value: byte); +begin + if not (Value in [1..4]) then Error(17{gesInvalidPixelDepth}); + if FTargetSPP<>Value then + begin + FTargetSPP:=Value; + FChanged:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.ConvertRow(Source: array of pointer; Target: pointer; Count: cardinal; Mask: byte); +// initializes the color conversion method if necessary and calls it to do the actual conversion +// +// Needed settings: +//-source and target BPS and SPP +//-main and display gamma, if gamma correction is wanted +//-conversion options +//-YCbCr parameters if any of the color schemes is csYCbCr +begin + // if there are pending changes then apply them + if FChanged then PrepareConversion; + // check if there's now a conversion method + if @FRowConversion=nil then Error(15{gesConversionUnsupported}) else FRowConversion(Source,Target,Count,Mask); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.CreateColorPalette(BMP: PBitmap; Data: array of pointer; DataFormat: TRawPaletteFormat; ColorCount: cardinal; RGB: boolean); +// Creates a color palette from the provided data which can be in various raw formats: +//-either interlaced or plane +//-8 bits or 16 bits per component +//-in RGB or BGR order +//-with 3 or 4 components per entry (fourth is ignored) +// ColorCount determines the number of color entries to create. If this number does not equal the +// number of palette entries which would result from the given target bits per sample resolution +// then the palette is adjusted accordingly to allow conversion between resolutions. +// +// Notes: For interlaced formats only one pointer needs to be passed in Data (only the first one is used) +// while for plane data 3 pointers are necessary (for each plane one pointer). +// The data order is assumed rgb or bgr in interlaced order (depending on RGB). In plane mode the three needed +// pointers must also be given such that the pointer to red components is in Data[0], the green pointer in +// Data[1] and the blue one in Data[2]. In this case BGR is not needed. +// +// Needed settings: +//-main and display gamma, if gamma correction is wanted +//-Options set as needed (gamma, byte swap) +//-source and target bits per sample resolution +var I,MaxIn,MaxOut: integer; + RunR8,RunG8,RunB8: PByte; + RunR16,RunG16,RunB16: PWord; + Convert8: function(Value: byte): byte of object; + Convert16: function(Value: word): byte of object; + R,G,B: byte; +begin + case DataFormat of + pfInterlaced8Triple, + pfInterlaced8Quad: + begin + RunR8:=Data[0]; + if coApplyGamma in FTargetOptions then Convert8:=ComponentGammaConvert else Convert8:=ComponentNoConvert8; + if RGB then + begin + for I:=0 to pred(ColorCount) do + begin + B:=Convert8(RunR8^); + Inc(RunR8); + G:=Convert8(RunR8^); + Inc(RunR8); + R:=Convert8(RunR8^); + Inc(RunR8); + BMP.DIBPalEntries[I]:=Windows.RGB(R,G,B); + if DataFormat=pfInterlaced8Quad then Inc(RunR8); + end; + end + else + begin + for I:=0 to pred(ColorCount) do + begin + R:=Convert8(RunR8^); + Inc(RunR8); + G:=Convert8(RunR8^); + Inc(RunR8); + B:=Convert8(RunR8^); + Inc(RunR8); + BMP.DIBPalEntries[I]:=Windows.RGB(R,G,B); + if DataFormat=pfInterlaced8Quad then Inc(RunR8); + end; + end; + end; + pfPlane8Triple, + pfPlane8Quad: + begin + RunR8:=Data[0]; + RunG8:=Data[1]; + RunB8:=Data[2]; + if coApplyGamma in FTargetOptions then Convert8:=ComponentGammaConvert else Convert8:=ComponentNoConvert8; + for I:=0 to pred(ColorCount) do + begin + R:=Convert8(RunR8^); + Inc(RunR8); + G:=Convert8(RunG8^); + Inc(RunG8); + B:=Convert8(RunB8^); + Inc(RunB8); + BMP.DIBPalEntries[I]:=Windows.RGB(R,G,B); + end; + end; + pfInterlaced16Triple, + pfInterlaced16Quad: + begin + RunR16:=Data[0]; + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16:=ComponentSwapScaleGammaConvert else Convert16:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16:=ComponentSwapScaleConvert else Convert16:=ComponentScaleConvert; + end; + if RGB then + begin + for I:=0 to pred(ColorCount) do + begin + R:=Convert16(RunR16^); + Inc(RunR16); + G:=Convert16(RunR16^); + Inc(RunR16); + B:=Convert16(RunR16^); + Inc(RunR16); + BMP.DIBPalEntries[I]:=Windows.RGB(R,G,B); + if DataFormat=pfInterlaced16Quad then Inc(RunR16); + end; + end + else + begin + for I:=0 to pred(ColorCount) do + begin + B:=Convert16(RunR16^); + Inc(RunR16); + G:=Convert16(RunR16^); + Inc(RunR16); + R:=Convert16(RunR16^); + Inc(RunR16); + BMP.DIBPalEntries[I]:=Windows.RGB(R,G,B); + if DataFormat=pfInterlaced16Quad then Inc(RunR16); + end; + end; + end; + pfPlane16Triple, + pfPlane16Quad: + begin + RunR16:=Data[0]; + RunG16:=Data[1]; + RunB16:=Data[2]; + if coApplyGamma in FTargetOptions then + begin + if coNeedbyteSwap in FSourceOptions then Convert16:=ComponentSwapScaleGammaConvert else Convert16:=ComponentScaleGammaConvert; + end + else + begin + if coNeedbyteSwap in FSourceOptions then Convert16:=ComponentSwapScaleConvert else Convert16:=ComponentScaleConvert; + end; + for I:=0 to pred(ColorCount) do + begin + R:=Convert16(RunR16^); + Inc(RunR16); + G:=Convert16(RunG16^); + Inc(RunG16); + B:=Convert16(RunB16^); + Inc(RunB16); + BMP.DIBPalEntries[I]:=Windows.RGB(B,G,R); + end; + end; + end; + MaxIn:=(1 shl FSourceBPS)-1; + MaxOut:=(1 shl FTargetBPS)-1; + if (FTargetBPS<=8) and (MaxIn<>MaxOut) then + begin + // If target resolution and given color depth differ then the palette needs to be adjusted. + // Consider the case for 2 bit to 4 bit conversion. Only 4 colors will be given to create + // the palette but after scaling all values will be up to 15 for which no color is in the palette. + // This and the reverse case need to be accounted for. + MaxIn:=(1 shl FSourceBPS)-1; + MaxOut:=(1 shl FTargetBPS)-1; + if MaxIn8 then BPS:=8; + Upper:=(1 shl BPS)-1; + Factor:=255 div Upper; + if MinimumIsWhite then + begin + if not (coApplyGamma in FTargetOptions) then + begin + for I:=0 to Upper do BMP.DIBPalEntries[Upper-I]:=RGB(I*Factor,I*Factor,I*Factor); + end + else + begin + for I:=0 to Upper do BMP.DIBPalEntries[Upper-I]:=RGB(FGammaTable[I*Factor],FGammaTable[I*Factor],FGammaTable[I*Factor]); + end; + end + else + begin + if not (coApplyGamma in FTargetOptions) then + begin + for I:=0 to Upper do BMP.DIBPalEntries[I]:=RGB(I*Factor,I*Factor,I*Factor); + end + else + begin + for I:=0 to Upper do BMP.DIBPalEntries[I]:=RGB(FGammaTable[I*Factor],FGammaTable[I*Factor],FGammaTable[I*Factor]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.Error(Code: integer); +var E: Exception; +begin + E:=Exception.Create(e_Custom,ErrorMsg[Code]); + E.ErrorCode:=Code; + raise E; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetGamma(MainGamma,DisplayGamma: single); +// sets the current gamma values and creates the gamma lookup table +// +// Needed settings: +//-source bits per samples must be set +//-target bits per samples must be set +var I,SourceHighBound,TargetHighBound: integer; + Gamma: single; +begin + if MainGamma<=0 then FMainGamma:=1 else FMainGamma:=MainGamma; + if DisplayGamma<=0 then FDisplayGamma:=2.2 {default value for a usual CRT} else FDisplayGamma:=DisplayGamma; + Gamma:=1/(FMainGamma*FDisplayGamma); + // source high bound is the maximum possible source value which can appear (0..255) + if FSourceBPS>=8 then SourceHighBound:=255 else SourceHighBound:=(1 shl FTargetBPS)-1; + // target high bound is the target value which corresponds to a target sample value of 1 (0..255) + if FTargetBPS>=8 then TargetHighBound:=255 else TargetHighBound:=(1 shl FTargetBPS)-1; + for I:=0 to SourceHighBound do + FGammaTable[I]:=Round(Power((I/SourceHighBound),Gamma)*TargetHighBound); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TColorManager.SetYCbCrParameters(Values: array of single; HSubSampling,VSubSampling: byte); +// sets coefficients needed to convert from YCbCr color scheme +begin + // there must always be at least one value in an open array + FYCbCrCoefficients[0]:=Values[0]; + if High(Values)>0 then + begin + FYCbCrCoefficients[1]:=Values[1]; + if High(Values)>1 then FYCbCrCoefficients[2]:=Values[2]; + end; + // subsampling can be 1, 2 or 4 and vertical subsampling must always be<=horizontal subsampling + if not (HSubSampling in [1,2,4]) then Error(18{gesInvalidSubSampling}); + if not (VSubSampling in [1,2,4]) then Error(18{gesInvalidSubSampling}); + if VSubSampling>HSubSampling then Error(19{gesVerticalSubSamplingError}); + FHSubSampling:=HSubSampling; + FVSubSampling:=VSubSampling; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. + diff --git a/Addons/KOLGraphicCompression.pas b/Addons/KOLGraphicCompression.pas new file mode 100644 index 0000000..2207759 --- /dev/null +++ b/Addons/KOLGraphicCompression.pas @@ -0,0 +1,1648 @@ +unit KOLGraphicCompression; + +// This file is part of the image library GraphicEx (www.lischke-online.de/Graphics.html). +// +// GraphicCompression contains various encoder/decoder classes used to handle compressed +// data in the various image classes. +// +// Currently supported methods are: +// - LZW (Lempel-Ziff-Welch) +// + TIF +// + GIF +// - RLE (run length encoding) +// + TGA, +// + PCX, +// + packbits +// + SGI +// + CUT +// + RLA +// + PSP +// - CCITT +// + raw G3 (fax T.4) +// + modified G3 (CCITT RLE) +// + modified G3 w/ word alignment (CCITT RLEW) +// - LZ77 +// - Thunderscan +// - JPEG +// - PCD Huffmann encoding (photo CD) +// +// (c) Copyright 1999, 2000 Dipl. Ing. Mike Lischke (public@lischke-online.de). All rights reserved. +// +// This package is freeware for non-commercial use only. +// Contact author for licenses (shareware@lischke-online.de) and see License.txt which comes with the package. + +////////////////////////////////////////////////// +// Converted to KOL by Dimaxx (dimaxx@atnet.ru) // +////////////////////////////////////////////////// + +interface + +{$ALIGN OFF} + +uses Windows, KOL, Err, Errors, MZLib; // general inflate/deflate and LZ77 compression support + +type + // abstract decoder class to define the base functionality of an encoder/decoder + TDecoder = class + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); virtual; abstract; + procedure DecodeEnd; virtual; + procedure DecodeInit; virtual; + end; + + // generally, there should be no need to cover the decoder classes by conditional symbols + // because the image classes which use the decoder classes are already covered and if they + // aren't compiled then the decoders are also not compiled (more precisely: not linked) + TTargaRLEDecoder = class(TDecoder) + private + FColorDepth: cardinal; + public + constructor Create(ColorDepth: cardinal); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + // Lempel-Ziff-Welch encoder/decoder class + // TIFF LZW compression / decompression is a bit different to the common LZW code + TTIFFLZWDecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TPackbitsRLEDecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TPCXRLEDecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TSGIRLEDecoder = class(TDecoder) + private + FSampleSize: byte; // 8 or 16 bits + public + constructor Create(SampleSize: byte); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TCUTRLEDecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TPSPRLEDecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + // Note: We need a different LZW decoder class for GIF because the bit order is reversed compared to that + // of TIFF and the code size increment is handled slightly different. + TGIFLZWDecoder = class(TDecoder) + private + FInitialCodeSize: byte; + public + constructor Create(InitialCodeSize: byte); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TRLADecoder = class(TDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TStateEntry = packed record + NewState: array[Boolean] of cardinal; + RunLength: integer; + end; + TStateArray = array of TStateEntry; + + TCCITTDecoder = class(TDecoder) + private + FOptions: integer; // determines some options how to proceed + // Bit 0: if set then two-dimensional encoding was used, otherwise one-dimensional + // Bit 1: if set then data is uncompressed + // Bit 2: if set then fill bits are used before EOL codes so that EOL codes always end at + // at a byte boundary (not used in this context) + FIsWhite, // alternating flag used while coding + FSwapBits: boolean; // True if the order of all bits in a byte must be swapped + FWhiteStates, + FBlackStates: TStateArray; + FWidth: cardinal; // need to know how line length for modified huffman encoding + // coding/encoding variables + FBitsLeft,FMask,FBits: byte; + FPackedSize,FRestWidth: cardinal; + FSource,FTarget: PByte; + FFreeTargetBits: byte; + FWordAligned: boolean; + procedure MakeStates; + protected + function FillRun(RunLength: cardinal): boolean; + function FindBlackCode: integer; + function FindWhiteCode: integer; + function NextBit: boolean; + public + constructor Create(Options: integer; SwapBits,WordAligned: boolean; Width: cardinal); + end; + + TCCITTFax3Decoder = class(TCCITTDecoder) + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TCCITTMHDecoder = class(TCCITTDecoder) // modified Huffman RLE + public + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TLZ77Decoder = class(TDecoder) + private + FStream: TZState; + FZLibResult, // contains the return code of the last ZLib operation + FFlushMode: integer; // one of flush constants declard in ZLib.pas + // this is usually Z_FINISH for PSP and Z_PARTIAL_FLUSH for PNG + FAutoReset: boolean; // TIF, PSP and PNG share this decoder, TIF needs a reset for each + // decoder run + function GetAvailableInput: integer; + function GetAvailableOutput: integer; + public + constructor Create(FlushMode: integer; AutoReset: boolean); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + procedure DecodeEnd; override; + procedure DecodeInit; override; + property AvailableInput: integer read GetAvailableInput; + property AvailableOutput: integer read GetAvailableOutput; + property ZLibResult: integer read FZLibResult; + end; + + TThunderDecoder = class(TDecoder) + private + FWidth: cardinal; // width of a scanline in pixels + public + constructor Create(Width: cardinal); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + + TPCDDecoder = class(TDecoder) + private + FStream: PStream; // decoder must read some data + public + constructor Create(Stream: PStream); + procedure Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); override; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses KOLMath, KOLGraphicEx, KOLGraphicColor; + +const // LZW encoding and decoding support + NoLZWCode = 4096; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure CompressionError(Code: integer); +var E: Exception; +begin + E:=Exception.Create(e_Custom,ErrorMsg[Code]); + E.ErrorCode:=Code; + raise E; +end; + +//----------------- TDecoder (generic decoder class) ------------------------------------------------------------------- + +procedure TDecoder.DecodeEnd; +// called after all decompression has been done +begin +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TDecoder.DecodeInit; +// called before any decompression can start +begin +end; + +//----------------- TTargaRLEDecoder ----------------------------------------------------------------------------------- + +constructor TTargaRLEDecoder.Create(ColorDepth: cardinal); +begin + FColorDepth:=ColorDepth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTargaRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +type + PCardinalArray = ^TCardinalArray; + TCardinalArray = array[0..MaxInt div 4-1] of Cardinal; +var I: integer; + SourcePtr,TargetPtr: PByte; + RunLength,Sourcecardinal: cardinal; +begin + TargetPtr:=Dest; + SourcePtr:=Source; + // unrolled decoder loop to speed up process + case FColorDepth of + 8: while UnpackedSize>0 do + begin + RunLength:=1+(SourcePtr^ and $7F); + if SourcePtr^>$7F then + begin + Inc(SourcePtr); + FillChar(TargetPtr^,RunLength,SourcePtr^); + Inc(TargetPtr,RunLength); + Inc(SourcePtr); + end + else + begin + Inc(SourcePtr); + Move(SourcePtr^,TargetPtr^,RunLength); + Inc(SourcePtr,RunLength); + Inc(TargetPtr,RunLength); + end; + Dec(UnpackedSize, RunLength); + end; + 15, + 16: while UnpackedSize>0 do + begin + RunLength:=1+(SourcePtr^ and $7F); + if SourcePtr^>$7F then + begin + Inc(SourcePtr); + for I:=0 to RunLength-1 do + begin + TargetPtr^:=SourcePtr^; + Inc(SourcePtr); + Inc(TargetPtr); + TargetPtr^:=SourcePtr^; + Dec(SourcePtr); + Inc(TargetPtr); + end; + Inc(SourcePtr,2); + end + else + begin + Inc(SourcePtr); + Move(SourcePtr^,TargetPtr^,2*RunLength); + Inc(SourcePtr,2*RunLength); + Inc(TargetPtr,2*RunLength); + end; + Dec(UnpackedSize,RunLength); + end; + 24: while UnpackedSize>0 do + begin + RunLength:=1+(SourcePtr^ and $7F); + if SourcePtr^>$7F then + begin + Inc(SourcePtr); + for I:=0 to RunLength-1 do + begin + TargetPtr^:=SourcePtr^; + Inc(SourcePtr); + Inc(TargetPtr); + TargetPtr^:=SourcePtr^; + Inc(SourcePtr); + Inc(TargetPtr); + TargetPtr^:=SourcePtr^; + Dec(SourcePtr,2); + Inc(TargetPtr); + end; + Inc(SourcePtr,3); + end + else + begin + Inc(SourcePtr); + Move(SourcePtr^,TargetPtr^,3*RunLength); + Inc(SourcePtr,3*RunLength); + Inc(TargetPtr,3*RunLength); + end; + Dec(UnpackedSize, RunLength); + end; + 32: while UnpackedSize>0 do + begin + RunLength:=1+(SourcePtr^ and $7F); + if SourcePtr^>$7F then + begin + Inc(SourcePtr); + SourceCardinal:=PCardinalArray(SourcePtr)[0]; + for I:=0 to RunLength-1 do + PCardinalArray(TargetPtr)[I]:=SourceCardinal; + Inc(TargetPtr,4*RunLength); + Inc(SourcePtr,4); + end + else + begin + Inc(SourcePtr); + Move(SourcePtr^,TargetPtr^,4*RunLength); + Inc(SourcePtr,4*RunLength); + Inc(TargetPtr,4*RunLength); + end; + Dec(UnpackedSize,RunLength); + end; + end; + Source:=SourcePtr; +end; + +//----------------- TTIFFLZWDecoder ------------------------------------------------------------------------------------ + +procedure TTIFFLZWDecoder.Decode(var Source, Dest: pointer; PackedSize, UnpackedSize: integer); +var I: integer; + Data, // current data + Bits, // counter for bit management + Code: cardinal; // current code value + SourcePtr: PByte; + InCode: cardinal; // Buffer for passed code + CodeSize,CodeMask,FreeCode,OldCode: cardinal; + Prefix: array[0..4095] of cardinal; // LZW prefix + Suffix, // LZW suffix + Stack: array[0..4095] of byte; // stack + Stackpointer,Target: PByte; + FirstChar: byte; // Buffer for decoded byte + ClearCode,EOICode: word; +begin + Target:=Dest; + SourcePtr:=Source; + // initialize parameter + ClearCode:=1 shl 8; + EOICode:=ClearCode+1; + FreeCode:=ClearCode+2; + OldCode:=NoLZWCode; + CodeSize:=9; + CodeMask:=(1 shl CodeSize)-1; + // init code table + for I:=0 to ClearCode-1 do + begin + Prefix[I]:=NoLZWCode; + Suffix[I]:=I; + end; + // initialize stack + Stackpointer:=@Stack; + FirstChar:=0; + Data:=0; + Bits:=0; + while (PackedSize>0) and (UnpackedSize>0) do + begin + // read code from bit stream + Inc(Data,cardinal(SourcePtr^) shl (24-Bits)); + Inc(Bits,8); + while Bits>=CodeSize do + begin + // current code + Code:=(Data and ($FFFFFFFF-CodeMask)) shr (32-CodeSize); + // mask it + Data:=Data shl CodeSize; + Dec(Bits,CodeSize); + if Code=EOICode then Exit; + // handling of clear codes + if Code=ClearCode then + begin + // reset of all variables + CodeSize:=9; + CodeMask:=(1 shl CodeSize)-1; + FreeCode:=ClearCode+2; + OldCode:=NoLZWCode; + Continue; + end; + // check whether it is a valid, already registered code + if Code>FreeCode then Break; + // handling for the first LZW code: print and keep it + if OldCode=NoLZWCode then + begin + FirstChar:=Suffix[Code]; + Target^:=FirstChar; + Inc(Target); + Dec(UnpackedSize); + OldCode:=Code; + Continue; + end; + // keep the passed LZW code + InCode:=Code; + // the first LZW code is always smaller than FFirstCode + if Code=FreeCode then + begin + Stackpointer^:=FirstChar; + Inc(StackPointer); + Code:=OldCode; + end; + // loop to put decoded bytes onto the stack + while Code>ClearCode do + begin + Stackpointer^:=Suffix[Code]; + Inc(StackPointer); + Code:=Prefix[Code]; + end; + // place new code into code table + FirstChar:=Suffix[Code]; + Stackpointer^:=FirstChar; + Inc(StackPointer); + Prefix[FreeCode]:=OldCode; + Suffix[FreeCode]:=FirstChar; + if FreeCode<4096 then Inc(FreeCode); + // increase code size if necessary + if (FreeCode=CodeMask) and (CodeSize<12) then + begin + Inc(CodeSize); + CodeMask:=(1 shl CodeSize)-1; + end; + // put decoded bytes (from the stack) into the target Buffer + OldCode:=InCode; + repeat + Dec(StackPointer); + Target^:=StackPointer^; + Inc(Target); + Dec(UnpackedSize); + until cardinal(Stackpointer)<=cardinal(@Stack); + end; + Inc(SourcePtr); + Dec(PackedSize); + end; +end; + +//----------------- TPackbitsRLEDecoder -------------------------------------------------------------------------------- + +procedure TPackbitsRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +// decodes a simple run-length encoded strip of size PackedSize +var SourcePtr,TargetPtr: PByte; + N: integer; +begin + TargetPtr:=Dest; + SourcePtr:=Source; + while (UnpackedSize>0) and (PackedSize>0) do + begin + N:=ShortInt(SourcePtr^); + Inc(SourcePtr); + Dec(PackedSize); + if N<0 then // replicate next Byte -N+1 times + begin + if N=-128 then Continue; // nop + N:=-N+1; + if N>UnpackedSize then N:=UnpackedSize; + FillChar(TargetPtr^,N,SourcePtr^); + Inc(SourcePtr); + Dec(PackedSize); + Inc(TargetPtr,N); + Dec(UnpackedSize,N); + end + else + begin // copy next N+1 bytes literally + Inc(N); + if N>UnpackedSize then N:=UnpackedSize; + if N>PackedSize then N:=PackedSize; + Move(SourcePtr^,TargetPtr^,N); + Inc(TargetPtr,N); + Inc(SourcePtr,N); + Dec(PackedSize,N); + Dec(UnpackedSize,N); + end; + end; +end; + +//----------------- TPCXRLEDecoder ------------------------------------------------------------------------------------- + +procedure TPCXRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var Count: integer; + SourcePtr,TargetPtr: PByte; +begin + SourcePtr:=Source; + TargetPtr:=Dest; + while UnpackedSize>0 do + begin + if (SourcePtr^ and $C0)=$C0 then + begin + // RLE-Code + Count:=SourcePtr^ and $3F; + Inc(SourcePtr); + if UnpackedSize0 then + begin + Move(Source8^,Target8^,RunLength); + Inc(Target8,RunLength); + Inc(Source8,RunLength); + end + else + begin + Pixel:=Source8^; + Inc(Source8); + FillChar(Target8^,RunLength,Pixel); + Inc(Target8,RunLength); + end; + end; + end + else + begin + // 16 bits per sample + Source16:=Source; + Target16:=Dest; + while True do + begin + // SGI images are stored in big endian style, swap this one repeater value for it + Pixel16:=System.Swap(Source16^); + Inc(Source16); + RunLength:=Pixel16 and $7F; + if RunLength=0 then Break; + if (Pixel16 and $80)<>0 then + begin + Move(Source16^,Target16^,2*RunLength); + Inc(Source16^,RunLength); + Inc(Target16^,RunLength); + end + else + begin + Pixel16:=Source16^; + Inc(Source16); + while RunLength>0 do + begin + Target16^:=Pixel16; + Inc(Target16); + Dec(RunLength); + end; + end; + end; + end; +end; + +//----------------- TCUTRLE -------------------------------------------------------------------------------------------- + +procedure TCUTRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var TargetPtr: PByte; + Pixel: byte; + RunLength: cardinal; +begin + TargetPtr:=Dest; + // skip first two bytes per row (I don't know their meaning) + Inc(PByte(Source),2); + while True do + begin + Pixel:=PByte(Source)^; + Inc(PByte(Source)); + if Pixel=0 then Break; + RunLength:=Pixel and $7F; + if (Pixel and $80)=0 then + begin + Move(Source^,TargetPtr^,RunLength); + Inc(TargetPtr,RunLength); + Inc(PByte(Source),RunLength); + end + else + begin + Pixel:=PByte(Source)^; + Inc(PByte(Source)); + FillChar(TargetPtr^,RunLength,Pixel); + Inc(TargetPtr,RunLength); + end; + end; +end; + +//----------------- TPSPRLEDecoder ------------------------------------------------------------------------------------- + +procedure TPSPRLEDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var SourcePtr,TargetPtr: PByte; + RunLength: cardinal; +begin + SourcePtr:=Source; + TargetPtr:=Dest; + while PackedSize>0 do + begin + RunLength:=SourcePtr^; + Inc(SourcePtr); + Dec(PackedSize); + if RunLength<128 then + begin + Move(SourcePtr^,TargetPtr^,RunLength); + Inc(TargetPtr,RunLength); + Inc(SourcePtr,RunLength); + Dec(PackedSize,RunLength); + end + else + begin + Dec(RunLength,128); + FillChar(TargetPtr^,RunLength,SourcePtr^); + Inc(SourcePtr); + Inc(TargetPtr,RunLength); + Dec(PackedSize); + end; + end; +end; + +//----------------- TGIFLZWDecoder ------------------------------------------------------------------------------------- + +constructor TGIFLZWDecoder.Create(InitialCodeSize: byte); +begin + FInitialCodeSize:=InitialCodeSize; +end; +//---------------------------------------------------------------------------------------------------------------------- + +procedure TGIFLZWDecoder.Decode(var Source, Dest: pointer; PackedSize,UnpackedSize: integer); +var I: integer; + Data, // current data + Bits, // counter for bit management + Code: cardinal; // current code value + SourcePtr: PByte; + InCode: cardinal; // Buffer for passed code + CodeSize,CodeMask,FreeCode,OldCode: cardinal; + Prefix: array[0..4095] of cardinal; // LZW prefix + Suffix, // LZW suffix + Stack: array[0..4095] of byte; // stack + StackPointer,Target: PByte; + FirstChar: byte; // Buffer for decoded byte + ClearCode,EOICode: word; +begin + Target:=Dest; + SourcePtr:=Source; + // initialize parameter + CodeSize:=FInitialCodeSize+1; + ClearCode:=1 shl FInitialCodeSize; + EOICode:=ClearCode+1; + FreeCode:=ClearCode+2; + OldCode:=NoLZWCode; + CodeMask:=(1 shl CodeSize)-1; + // init code table + for I:=0 to ClearCode-1 do + begin + Prefix[I]:=NoLZWCode; + Suffix[I]:=I; + end; + // initialize stack + StackPointer:=@Stack; + FirstChar:=0; + Data:=0; + Bits:=0; + while (UnpackedSize>0) and (PackedSize>0) do + begin + // read code from bit stream + Inc(Data,SourcePtr^ shl Bits); + Inc(Bits,8); + while Bits>=CodeSize do + begin + // current code + Code:=Data and CodeMask; + // prepare next run + Data:=Data shr CodeSize; + Dec(Bits,CodeSize); + // decoding finished? + if Code=EOICode then Break; + // handling of clear codes + if Code=ClearCode then + begin + // reset of all variables + CodeSize:=FInitialCodeSize+1; + CodeMask:=(1 shl CodeSize)-1; + FreeCode:=ClearCode+2; + OldCode:=NoLZWCode; + Continue; + end; + // check whether it is a valid, already registered code + if Code>FreeCode then Break; + // handling for the first LZW code: print and keep it + if OldCode=NoLZWCode then + begin + FirstChar:=Suffix[Code]; + Target^:=FirstChar; + Inc(Target); + Dec(UnpackedSize); + OldCode:=Code; + Continue; + end; + // keep the passed LZW code + InCode:=Code; + // the first LZW code is always smaller than FFirstCode + if Code=FreeCode then + begin + StackPointer^:=FirstChar; + Inc(StackPointer); + Code:=OldCode; + end; + // loop to put decoded bytes onto the stack + while Code>ClearCode do + begin + StackPointer^:=Suffix[Code]; + Inc(StackPointer); + Code:=Prefix[Code]; + end; + // place new code into code table + FirstChar:=Suffix[Code]; + Stackpointer^:=FirstChar; + Inc(Stackpointer); + Prefix[FreeCode]:=OldCode; + Suffix[FreeCode]:=FirstChar; + // increase code size if necessary + if (FreeCode=CodeMask) and (CodeSize<12) then + begin + Inc(CodeSize); + CodeMask:=(1 shl CodeSize)-1; + end; + if FreeCode<4095 then Inc(FreeCode); + // put decoded bytes (from the stack) into the target Buffer + OldCode:=InCode; + repeat + Dec(StackPointer); + Target^:=StackPointer^; + Inc(Target); + Dec(UnpackedSize); + until StackPointer=@Stack; + end; + Inc(SourcePtr); + Dec(PackedSize); + end; +end; + +//----------------- TRLADecoder ---------------------------------------------------------------------------------------- + +procedure TRLADecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +// decodes a simple run-length encoded strip of size PackedSize +// this is very similar to TPackbitsRLEDecoder +var SourcePtr,TargetPtr: PByte; + N: smallint; +begin + TargetPtr:=Dest; + SourcePtr:=Source; + while PackedSize>0 do + begin + N:=ShortInt(SourcePtr^); + Inc(SourcePtr); + Dec(PackedSize); + if N>=0 then // replicate next Byte N+1 times + begin + FillChar(TargetPtr^,N+1,SourcePtr^); + Inc(TargetPtr,N+1); + Inc(SourcePtr); + Dec(PackedSize); + end + else + begin // copy next -N bytes literally + Move(SourcePtr^,TargetPtr^,-N); + Inc(TargetPtr,-N); + Inc(SourcePtr,-N); + Inc(PackedSize,N); + end; + end; +end; + +//----------------- TCCITTDecoder -------------------------------------------------------------------------------------- + +constructor TCCITTDecoder.Create(Options: integer; SwapBits,WordAligned: boolean; Width: cardinal); +begin + FOptions:=Options; + FSwapBits:=SwapBits; + FWidth:=Width; + FWordAligned:=WordAligned; + MakeStates; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +const + // 256 bytes to make bit reversing easy, + // this is actually not much more than writing bit manipulation code, but much faster + ReverseTable: array[0..255] of byte = ( + $00,$80,$40,$C0,$20,$A0,$60,$E0,$10,$90,$50,$D0,$30,$B0,$70,$F0, + $08,$88,$48,$C8,$28,$A8,$68,$E8,$18,$98,$58,$D8,$38,$B8,$78,$F8, + $04,$84,$44,$C4,$24,$A4,$64,$E4,$14,$94,$54,$D4,$34,$B4,$74,$F4, + $0C,$8C,$4C,$CC,$2C,$AC,$6C,$EC,$1C,$9C,$5C,$DC,$3C,$BC,$7C,$FC, + $02,$82,$42,$C2,$22,$A2,$62,$E2,$12,$92,$52,$D2,$32,$B2,$72,$F2, + $0A,$8A,$4A,$CA,$2A,$AA,$6A,$EA,$1A,$9A,$5A,$DA,$3A,$BA,$7A,$FA, + $06,$86,$46,$C6,$26,$A6,$66,$E6,$16,$96,$56,$D6,$36,$B6,$76,$F6, + $0E,$8E,$4E,$CE,$2E,$AE,$6E,$EE,$1E,$9E,$5E,$DE,$3E,$BE,$7E,$FE, + $01,$81,$41,$C1,$21,$A1,$61,$E1,$11,$91,$51,$D1,$31,$B1,$71,$F1, + $09,$89,$49,$C9,$29,$A9,$69,$E9,$19,$99,$59,$D9,$39,$B9,$79,$F9, + $05,$85,$45,$C5,$25,$A5,$65,$E5,$15,$95,$55,$D5,$35,$B5,$75,$F5, + $0D,$8D,$4D,$CD,$2D,$AD,$6D,$ED,$1D,$9D,$5D,$DD,$3D,$BD,$7D,$FD, + $03,$83,$43,$C3,$23,$A3,$63,$E3,$13,$93,$53,$D3,$33,$B3,$73,$F3, + $0B,$8B,$4B,$CB,$2B,$AB,$6B,$EB,$1B,$9B,$5B,$DB,$3B,$BB,$7B,$FB, + $07,$87,$47,$C7,$27,$A7,$67,$E7,$17,$97,$57,$D7,$37,$B7,$77,$F7, + $0F,$8F,$4F,$CF,$2F,$AF,$6F,$EF,$1F,$9F,$5F,$DF,$3F,$BF,$7F,$FF); + + G3_EOL = -1; + G3_INVALID = -2; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCCITTDecoder.FillRun(RunLength: cardinal): boolean; +// fills a number of bits with 1s (for black, white only increments pointers), +// returns True if the line has been filled entirely, otherwise False +var Run: cardinal; +begin + Run:=KOL.Min(FFreeTargetBits,RunLength); + // fill remaining bits in the current byte + if Run in [1..7] then + begin + Dec(FFreeTargetBits,Run); + if not FIsWhite then FTarget^:=FTarget^ or (((1 shl Run)-1) shl FFreeTargetBits); + if FFreeTargetBits=0 then + begin + Inc(FTarget); + FFreeTargetBits:=8; + end; + Run:=RunLength-Run; + end + else Run:=RunLength; + // fill entire bytes whenever possible + if Run>0 then + begin + if not FIsWhite then FillChar(FTarget^,Run div 8,$FF); + Inc(FTarget,Run div 8); + Run:=Run mod 8; + end; + // finally fill remaining bits + if Run>0 then + begin + FFreeTargetBits:=8-Run; + if not FIsWhite then FTarget^:=((1 shl Run)-1) shl FFreeTargetBits; + end; + // this will throw an exception if the sum of the run lengths for a row is not + // exactly the row size (the documentation speaks of an unrecoverable error) + if cardinal(RunLength)>FRestWidth then RunLength:=FRestWidth; + Dec(FRestWidth,RunLength); + Result:=FRestWidth=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCCITTDecoder.FindBlackCode: integer; +// Executes the state machine to find the run length for the next bit combination. +// Returns the run length of the found code. +var State,NewState: cardinal; + Bit: boolean; +begin + State:=0; + Result:=0; + repeat + // advance to next byte in the input Buffer if necessary + if FBitsLeft=0 then + begin + if FPackedSize=0 then Break; + FBits:=FSource^; + Inc(FSource); + Dec(FPackedSize); + FMask:=$80; + FBitsLeft:=8; + end; + Bit:=(FBits and FMask)<>0; + // advance the state machine + NewState:=FBlackStates[State].NewState[Bit]; + if NewState=0 then + begin + Inc(Result,FBlackStates[State].RunLength); + if FBlackStates[State].RunLength<64 then Break else NewState:=FBlackStates[0].NewState[Bit]; + end; + State:=NewState; + // address next bit + FMask:=FMask shr 1; + if FBitsLeft>0 then Dec(FBitsLeft); + until False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCCITTDecoder.FindWhiteCode: integer; +// Executes the state machine to find the run length for the next bit combination. +// Returns the run length of the found code. +var State,NewState: cardinal; + Bit: boolean; +begin + State:=0; + Result:=0; + repeat + // advance to next byte in the input Buffer if necessary + if FBitsLeft=0 then + begin + if FPackedSize=0 then Break; + FBits:=FSource^; + Inc(FSource); + Dec(FPackedSize); + FMask:=$80; + FBitsLeft:=8; + end; + Bit:=(FBits and FMask)<>0; + // advance the state machine + NewState:=FWhiteStates[State].NewState[Bit]; + if NewState=0 then + begin + // a code has been found + Inc(Result,FWhiteStates[State].RunLength); + // if we found a terminating code then exit loop, otherwise continue + if FWhiteStates[State].RunLength<64 then Break else + begin + // found a make up code, continue state machine with current bit (rather than reading the next one) + NewState:=FWhiteStates[0].NewState[Bit]; + end; + end; + State:=NewState; + // address next bit + FMask:=FMask shr 1; + if FBitsLeft>0 then Dec(FBitsLeft); + until False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCCITTDecoder.NextBit: boolean; +// Reads the current bit and returns True if it is set, otherwise False. +// This method is only used in the process to synchronize the bit stream in descentants. +begin + // advance to next byte in the input Buffer if necessary + if (FBitsLeft=0) and (FPackedSize>0) then + begin + FBits:=FSource^; + Inc(FSource); + Dec(FPackedSize); + FMask:=$80; + FBitsLeft:=8; + end; + Result:=(FBits and FMask)<>0; + // address next bit + FMask:=FMask shr 1; + if FBitsLeft>0 then Dec(FBitsLeft); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + TCodeEntry = packed record + Code,Len: cardinal; + end; + +const // CCITT code tables + WhiteCodes: array[0..103] of TCodeEntry = ( + (Code: $0035; Len: 8),(Code: $0007; Len: 6),(Code: $0007; Len: 4), + (Code: $0008; Len: 4),(Code: $000B; Len: 4),(Code: $000C; Len: 4), + (Code: $000E; Len: 4),(Code: $000F; Len: 4),(Code: $0013; Len: 5), + (Code: $0014; Len: 5),(Code: $0007; Len: 5),(Code: $0008; Len: 5), + (Code: $0008; Len: 6),(Code: $0003; Len: 6),(Code: $0034; Len: 6), + (Code: $0035; Len: 6),(Code: $002A; Len: 6),(Code: $002B; Len: 6), + (Code: $0027; Len: 7),(Code: $000C; Len: 7),(Code: $0008; Len: 7), + (Code: $0017; Len: 7),(Code: $0003; Len: 7),(Code: $0004; Len: 7), + (Code: $0028; Len: 7),(Code: $002B; Len: 7),(Code: $0013; Len: 7), + (Code: $0024; Len: 7),(Code: $0018; Len: 7),(Code: $0002; Len: 8), + (Code: $0003; Len: 8),(Code: $001A; Len: 8),(Code: $001B; Len: 8), + (Code: $0012; Len: 8),(Code: $0013; Len: 8),(Code: $0014; Len: 8), + (Code: $0015; Len: 8),(Code: $0016; Len: 8),(Code: $0017; Len: 8), + (Code: $0028; Len: 8),(Code: $0029; Len: 8),(Code: $002A; Len: 8), + (Code: $002B; Len: 8),(Code: $002C; Len: 8),(Code: $002D; Len: 8), + (Code: $0004; Len: 8),(Code: $0005; Len: 8),(Code: $000A; Len: 8), + (Code: $000B; Len: 8),(Code: $0052; Len: 8),(Code: $0053; Len: 8), + (Code: $0054; Len: 8),(Code: $0055; Len: 8),(Code: $0024; Len: 8), + (Code: $0025; Len: 8),(Code: $0058; Len: 8),(Code: $0059; Len: 8), + (Code: $005A; Len: 8),(Code: $005B; Len: 8),(Code: $004A; Len: 8), + (Code: $004B; Len: 8),(Code: $0032; Len: 8),(Code: $0033; Len: 8), + (Code: $0034; Len: 8),(Code: $001B; Len: 5),(Code: $0012; Len: 5), + (Code: $0017; Len: 6),(Code: $0037; Len: 7),(Code: $0036; Len: 8), + (Code: $0037; Len: 8),(Code: $0064; Len: 8),(Code: $0065; Len: 8), + (Code: $0068; Len: 8),(Code: $0067; Len: 8),(Code: $00CC; Len: 9), + (Code: $00CD; Len: 9),(Code: $00D2; Len: 9),(Code: $00D3; Len: 9), + (Code: $00D4; Len: 9),(Code: $00D5; Len: 9),(Code: $00D6; Len: 9), + (Code: $00D7; Len: 9),(Code: $00D8; Len: 9),(Code: $00D9; Len: 9), + (Code: $00DA; Len: 9),(Code: $00DB; Len: 9),(Code: $0098; Len: 9), + (Code: $0099; Len: 9),(Code: $009A; Len: 9),(Code: $0018; Len: 6), + (Code: $009B; Len: 9),(Code: $0008; Len: 11),(Code: $000C; Len: 11), + (Code: $000D; Len: 11),(Code: $0012; Len: 12),(Code: $0013; Len: 12), + (Code: $0014; Len: 12),(Code: $0015; Len: 12),(Code: $0016; Len: 12), + (Code: $0017; Len: 12),(Code: $001C; Len: 12),(Code: $001D; Len: 12), + (Code: $001E; Len: 12),(Code: $001F; Len: 12)); + // EOL codes are added "manually" + + BlackCodes: array[0..103] of TCodeEntry = ( + (Code: $0037; Len: 10),(Code: $0002; Len: 3),(Code: $0003; Len: 2), + (Code: $0002; Len: 2),(Code: $0003; Len: 3),(Code: $0003; Len: 4), + (Code: $0002; Len: 4),(Code: $0003; Len: 5),(Code: $0005; Len: 6), + (Code: $0004; Len: 6),(Code: $0004; Len: 7),(Code: $0005; Len: 7), + (Code: $0007; Len: 7),(Code: $0004; Len: 8),(Code: $0007; Len: 8), + (Code: $0018; Len: 9),(Code: $0017; Len: 10),(Code: $0018; Len: 10), + (Code: $0008; Len: 10),(Code: $0067; Len: 11),(Code: $0068; Len: 11), + (Code: $006C; Len: 11),(Code: $0037; Len: 11),(Code: $0028; Len: 11), + (Code: $0017; Len: 11),(Code: $0018; Len: 11),(Code: $00CA; Len: 12), + (Code: $00CB; Len: 12),(Code: $00CC; Len: 12),(Code: $00CD; Len: 12), + (Code: $0068; Len: 12),(Code: $0069; Len: 12),(Code: $006A; Len: 12), + (Code: $006B; Len: 12),(Code: $00D2; Len: 12),(Code: $00D3; Len: 12), + (Code: $00D4; Len: 12),(Code: $00D5; Len: 12),(Code: $00D6; Len: 12), + (Code: $00D7; Len: 12),(Code: $006C; Len: 12),(Code: $006D; Len: 12), + (Code: $00DA; Len: 12),(Code: $00DB; Len: 12),(Code: $0054; Len: 12), + (Code: $0055; Len: 12),(Code: $0056; Len: 12),(Code: $0057; Len: 12), + (Code: $0064; Len: 12),(Code: $0065; Len: 12),(Code: $0052; Len: 12), + (Code: $0053; Len: 12),(Code: $0024; Len: 12),(Code: $0037; Len: 12), + (Code: $0038; Len: 12),(Code: $0027; Len: 12),(Code: $0028; Len: 12), + (Code: $0058; Len: 12),(Code: $0059; Len: 12),(Code: $002B; Len: 12), + (Code: $002C; Len: 12),(Code: $005A; Len: 12),(Code: $0066; Len: 12), + (Code: $0067; Len: 12),(Code: $000F; Len: 10),(Code: $00C8; Len: 12), + (Code: $00C9; Len: 12),(Code: $005B; Len: 12),(Code: $0033; Len: 12), + (Code: $0034; Len: 12),(Code: $0035; Len: 12),(Code: $006C; Len: 13), + (Code: $006D; Len: 13),(Code: $004A; Len: 13),(Code: $004B; Len: 13), + (Code: $004C; Len: 13),(Code: $004D; Len: 13),(Code: $0072; Len: 13), + (Code: $0073; Len: 13),(Code: $0074; Len: 13),(Code: $0075; Len: 13), + (Code: $0076; Len: 13),(Code: $0077; Len: 13),(Code: $0052; Len: 13), + (Code: $0053; Len: 13),(Code: $0054; Len: 13),(Code: $0055; Len: 13), + (Code: $005A; Len: 13),(Code: $005B; Len: 13),(Code: $0064; Len: 13), + (Code: $0065; Len: 13),(Code: $0008; Len: 11),(Code: $000C; Len: 11), + (Code: $000D; Len: 11),(Code: $0012; Len: 12),(Code: $0013; Len: 12), + (Code: $0014; Len: 12),(Code: $0015; Len: 12),(Code: $0016; Len: 12), + (Code: $0017; Len: 12),(Code: $001C; Len: 12),(Code: $001D; Len: 12), + (Code: $001E; Len: 12),(Code: $001F; Len: 12)); + // EOL codes are added "manually" + +procedure TCCITTDecoder.MakeStates; +// creates state arrays for white and black codes +// These state arrays are so designed that they have at each state (starting with state 0) a new state index +// into the same array according to the bit for which the state is current. + + //--------------- local functions ------------------------------------------- + procedure AddCode(var Target: TStateArray; Bits: cardinal; BitLen,RL: integer); + // interprets the given string as a sequence of bits and makes a state chain from it + var State,NewState: integer; + Bit: boolean; + begin + // start state + State:=0; + // prepare bit combination (bits are given right align, but must be scanned from left) + Bits:=Bits shl (32-BitLen); + while BitLen>0 do + begin + // determine next state according to the bit string + asm + SHL [Bits],1 + SETC [Bit] + end; + NewState:=Target[State].NewState[Bit]; + // Is it a not yet assigned state? + if NewState=0 then + begin + // if yes then create a new state at the end of the array + NewState:=Length(Target); + Target[State].NewState[Bit]:=NewState; + SetLength(Target,Length(Target)+1); + end; + State:=NewState; + Dec(BitLen); + end; + // at this point State indicates the final state where we must store the run length for the + // particular bit combination + Target[State].RunLength:=RL; + end; + //--------------- end local functions --------------------------------------- +var I: integer; +begin + // set an initial entry in each state array + SetLength(FWhiteStates,1); + SetLength(FBlackStates,1); + // with codes + for I:=0 to 63 do with WhiteCodes[I] do AddCode(FWhiteStates,Code,Len,I); + for I:=64 to 103 do with WhiteCodes[I] do AddCode(FWhiteStates,Code,Len,(I-63)*64); + AddCode(FWhiteStates,1,12,G3_EOL); + AddCode(FWhiteStates,1,9,G3_INVALID); + AddCode(FWhiteStates,1,10,G3_INVALID); + AddCode(FWhiteStates,1,11,G3_INVALID); + AddCode(FWhiteStates,0,12,G3_INVALID); + // black codes + for I:=0 to 63 do with BlackCodes[I] do AddCode(FBlackStates,Code,Len,I); + for I:=64 to 103 do with BlackCodes[I] do AddCode(FBlackStates,Code,Len,(I-63)*64); + AddCode(FBlackStates,1,12,G3_EOL); + AddCode(FBlackStates,1,9,G3_INVALID); + AddCode(FBlackStates,1,10,G3_INVALID); + AddCode(FBlackStates,1,11,G3_INVALID); + AddCode(FBlackStates,0,12,G3_INVALID); +end; + +//----------------- TCCITTFax3Decoder ---------------------------------------------------------------------------------- + +procedure TCCITTFax3Decoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var + RunLength: integer; + EOLCount: integer; + //--------------- local functions ------------------------------------------- + procedure SynchBOL; + // synch bit stream to next line start + var Count: integer; + begin + // if no EOL codes have been read so far then do it now + if EOLCount=0 then + begin + // advance until 11 consecutive 0 bits have been found + Count:=0; + while (Count<11) and (FPackedSize>0) do + begin + if NextBit then Count:=0 else Inc(Count); + end; + end; + // read 8 bit until at least one set bit is found + repeat + Count:=0; + while (Count<8) and (FPackedSize>0) do + begin + if NextBit then Count:=9 else Inc(Count); + end; + until (Count>8) or (FPackedSize=0); + // here we are already beyond the set bit and can restart scanning + EOLCount:=0; + end; + //--------------------------------------------------------------------------- + procedure AdjustEOL; + begin + FIsWhite:=False; + if FFreeTargetBits in [1..7] then Inc(FTarget); + FFreeTargetBits:=8; + FRestWidth:=FWidth; + end; + //--------------- end local functions --------------------------------------- +begin + // make all bits white + FillChar(Dest^,UnpackedSize,0); + // swap all bits here, in order to avoid frequent tests in the main loop + if FSwapBits then + asm + PUSH EBX + LEA EBX,ReverseTable + MOV ECX,[PackedSize] + MOV EDX,[Source] + MOV EDX,[EDX] + @@1: + MOV AL,[EDX] + XLAT + MOV [EDX],AL + INC EDX + DEC ECX + JNZ @@1 + POP EBX + end; + // setup initial states + // a row always starts with a (possibly zero-length) white run + FSource:=Source; + FBitsLeft:=0; + FPackedSize:=PackedSize; + // target preparation + FTarget:=Dest; + FRestWidth:=FWidth; + FFreeTargetBits:=8; + EOLCount:=0; + // main loop + repeat + // synchronize to start of next line + SynchBOL; + // a line always starts with a white run + FIsWhite:=True; + // decode one line + repeat + if FIsWhite then RunLength:=FindWhiteCode else RunLength:=FindBlackCode; + if RunLength>=0 then + begin + if FillRun(RunLength) then Break; + FIsWhite:=not FIsWhite; + end + else + if RunLength=G3_EOL then Inc(EOLCount) else Break; + until (RunLength=G3_EOL) or (FPackedSize=0); + AdjustEOL; + until (FPackedSize=0) or (FTarget-PChar(Dest)>=UnpackedSize); +end; + +//----------------- TCCITTMHDecoder ------------------------------------------------------------------------------------ + +procedure TCCITTMHDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var RunLength: integer; + //--------------- local functions ------------------------------------------- + procedure AdjustEOL; + begin + FIsWhite:=False; + if FFreeTargetBits in [1..7] then Inc(FTarget); + FFreeTargetBits:=8; + FRestWidth:=FWidth; + if FBitsLeft<8 then FBitsLeft:=0; // discard remaining bits + if FWordAligned and Odd(cardinal(FTarget)) then Inc(FTarget); + end; + //--------------- end local functions --------------------------------------- +begin + // make all bits white + FillChar(Dest^, UnpackedSize,0); + // swap all bits here, in order to avoid frequent tests in the main loop + if FSwapBits then + asm + PUSH EBX + LEA EBX,ReverseTable + MOV ECX,[PackedSize] + MOV EDX,[Source] + MOV EDX,[EDX] + @@1: + MOV AL,[EDX] + XLAT + MOV [EDX],AL + INC EDX + DEC ECX + JNZ @@1 + POP EBX + end; + + // setup initial states + // a row always starts with a (possibly zero-length) white run + FIsWhite:=True; + FSource:=Source; + FBitsLeft:=0; + FPackedSize:=PackedSize; + // target preparation + FTarget:=Dest; + FRestWidth:=FWidth; + FFreeTargetBits:=8; + // main loop + repeat + if FIsWhite then RunLength:=FindWhiteCode else RunLength:=FindBlackCode; + if RunLength>0 then + if FillRun(RunLength) then AdjustEOL; + FIsWhite:=not FIsWhite; + until FPackedSize=0; +end; + +//----------------- TLZ77Decoder --------------------------------------------------------------------------------------- + +constructor TLZ77Decoder.Create(FlushMode: integer; AutoReset: boolean); +begin + FillChar(FStream,sizeof(FStream),0); + FFlushMode:=FlushMode; + FAutoReset:=AutoReset; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TLZ77Decoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +begin + FStream.NextInput:=Source; + FStream.AvailableInput:=PackedSize; + if FAutoReset then FZLibResult:=InflateReset(FStream); + if FZLibResult=Z_OK then + begin + FStream.NextOutput:=Dest; + FStream.AvailableOutput:=UnpackedSize; + FZLibResult:=Inflate(FStream,FFlushMode); + // advance pointers so used input can be calculated + Source:=FStream.NextInput; + Dest:=FStream.NextOutput; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TLZ77Decoder.DecodeEnd; +begin + if InflateEnd(FStream)<0 then CompressionError(20{gesLZ77Error}); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TLZ77Decoder.DecodeInit; +begin + if InflateInit(FStream)<0 then CompressionError(20{gesLZ77Error}); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TLZ77Decoder.GetAvailableInput: integer; +begin + Result:=FStream.AvailableInput; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TLZ77Decoder.GetAvailableOutput: integer; +begin + Result:=FStream.AvailableOutput; +end; + +//----------------- TThunderDecoder ------------------------------------------------------------------------------------ + +// ThunderScan uses an encoding scheme designed for 4-bit pixel values. Data is encoded in bytes, with +// each byte split into a 2-bit code word and a 6-bit data value. The encoding gives raw data, runs of +// pixels, or pixel values encoded as a delta from the previous pixel value. For the latter, either 2-bit +// or 3-bit delta values are used, with the deltas packed into a single byte. + +const + THUNDER_DATA = $3F; // mask for 6-bit data + THUNDER_CODE = $C0; // mask for 2-bit code word + // code values + THUNDER_RUN = 0; // run of pixels w/ encoded count + THUNDER_2BITDELTAS = $40; // 3 pixels w/ encoded 2-bit deltas + DELTA2_SKIP = 2; // skip code for 2-bit deltas + THUNDER_3BITDELTAS = $80; // 2 pixels w/ encoded 3-bit deltas + DELTA3_SKIP = 4; // skip code for 3-bit deltas + THUNDER_RAW = $C0; // raw data encoded + + TwoBitDeltas: array[0..3] of integer = (0,1,0,-1); + ThreeBitDeltas: array[0..7] of integer = (0,1,2,3,0,-3,-2,-1); + +constructor TThunderDecoder.Create(Width: cardinal); +begin + FWidth:=Width; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TThunderDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +var SourcePtr,TargetPtr: PByte; + LastPixel,N,Delta: integer; + NPixels: cardinal; + //--------------- local function -------------------------------------------- + procedure SetPixel(Delta: integer); + begin + Lastpixel:=Delta and $0F; + if Odd(NPixels) then + begin + TargetPtr^:=TargetPtr^ or LastPixel; + Inc(TargetPtr); + end + else TargetPtr^:=LastPixel shl 4; + Inc(NPixels); + end; + //--------------- end local function ---------------------------------------- +begin + SourcePtr:=Source; + TargetPtr:=Dest; + while UnpackedSize>0 do + begin + LastPixel:=0; + NPixels:=0; + // Usually Width represents the byte number of a strip, but the thunder + // algo is only defined for 4 bits per pixel formats where 2 pixels take up + // one byte. + while (PackedSize>0) and (NPixels<2*FWidth) do + begin + N:=SourcePtr^; + Inc(SourcePtr); + Dec(PackedSize); + case N and THUNDER_CODE of + THUNDER_RUN: + // pixel run, replicate the last pixel n times, where n is the lower-order 6 bits + begin + if Odd(NPixels) then + begin + TargetPtr^:=TargetPtr^ or Lastpixel; + Lastpixel:=TargetPtr^; + Inc(TargetPtr); + Inc(NPixels); + Dec(N); + end + else LastPixel:=LastPixel or LastPixel shl 4; + Inc(NPixels, N); + while N>0 do + begin + TargetPtr^:=LastPixel; + Inc(TargetPtr); + Dec(N, 2); + end; + if N = -1 then + begin + Dec(TargetPtr); + TargetPtr^:=TargetPtr^ and $F0; + end; + LastPixel:=LastPixel and $0F; + end; + THUNDER_2BITDELTAS: // 2-bit deltas + begin + Delta:=(N shr 4) and 3; + if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]); + Delta:=(N shr 2) and 3; + if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]); + Delta:=N and 3; + if Delta<>DELTA2_SKIP then SetPixel(LastPixel+TwoBitDeltas[Delta]); + end; + THUNDER_3BITDELTAS: // 3-bit deltas + begin + Delta:=(N shr 3) and 7; + if Delta<>DELTA3_SKIP then SetPixel(LastPixel+ThreeBitDeltas[Delta]); + Delta:=N and 7; + if Delta<>DELTA3_SKIP then SetPixel(LastPixel+ThreeBitDeltas[Delta]); + end; + THUNDER_RAW: // raw data + SetPixel(N); + end; + end; + Dec(UnpackedSize,FWidth); + end; +end; + +//----------------- TPCDDecoder ---------------------------------------------------------------------------------------- + +constructor TPCDDecoder.Create(Stream: PStream); +begin + FStream:=Stream; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPCDDecoder.Decode(var Source,Dest: pointer; PackedSize,UnpackedSize: integer); +// recovers the Huffman encoded luminance and chrominance deltas +// Note: This decoder leaves a bit the way like the other decoders work. +// Source points to an array of 3 pointers, one for luminance (Y, Luma), one for blue +// chrominance (Cb, Chroma1) and one for red chrominance (Cr, Chroma2). These pointers +// point to source and target at the same time (in place decoding). +// PackedSize contains the width of the current subimage and UnpackedSize its height. +// Dest is not used and can be nil. +type + PPointerArray = ^TPointerArray; + TPointerArray = array[0..2] of pointer; + PPCDTable = ^TPCDTable; + TPCDTable = packed record + Length: byte; + Sequence: cardinal; + Key: byte; + Mask: integer; + end; + PQuantumArray = ^TQuantumArray; + TQuantumArray = array[0..3*256-1] of byte; +var + Luma,Chroma1,Chroma2: PChar; // hold the actual pointers, PChar to easy pointer maths + Width,Height: cardinal; + PCDTable: array[0..2] of PPCDTable; + I,J,K: cardinal; + R: PPCDTable; + RangeLimit: PQuantumArray; + P,Q,Buffer: PChar; + Accumulator,Bits,Length,Plane,Row: cardinal; + PCDLength: array[0..2] of cardinal; + + //--------------- local function -------------------------------------------- + procedure PCDGetBits(N: cardinal); + begin + Accumulator:=Accumulator shl N; + Dec(Bits,N); + while Bits<=24 do + begin + if P>=(Buffer+$800) then + begin + FStream.Read(Buffer^,$800); + P:=Buffer; + end; + Accumulator:=Accumulator or (cardinal(P^) shl (24-Bits)); + Inc(Bits,8); + Inc(P); + end; + end; + //--------------- end local function ---------------------------------------- +var Limit: cardinal; +begin + // place the used source values into local variables with proper names to make + // their usage clearer + Luma:=PPointerArray(Source)[0]; + Chroma1:=PPointerArray(Source)[1]; + Chroma2:=PPointerArray(Source)[2]; + Width:=PackedSize; + Height:=UnpackedSize; + // initialize Huffman tables + ZeroMemory(@PCDTable,sizeof(PCDTable)); + GetMem(Buffer,$800); + try + Accumulator:=0; + Bits:=32; + P:=Buffer+$800; + Limit:=1; + if Width>1536 then Limit:=3; + for I:=0 to Limit-1 do + begin + PCDGetBits(8); + Length:=(Accumulator and $FF)+1; + GetMem(PCDTable[I],Length*sizeof(TPCDTable)); + R:=PCDTable[I]; + for J:=0 to Length-1 do + begin + PCDGetBits(8); + R.Length:=(Accumulator and $FF)+1; + if R.Length>16 then + begin + if Assigned(Buffer) then FreeMem(Buffer); + for K:=0 to 2 do + if Assigned(PCDTable[K]) then FreeMem(PCDTable[K]); + Exit; + end; + PCDGetBits(16); + R.Sequence:=(Accumulator and $FFFF) shl 16; + PCDGetBits(8); + R.Key:=Accumulator and $FF; + asm + // R.Mask:=not ((1 shl (32-R.Length))-1); + // asm implementation to avoid overflow errors and for faster execution + MOV EDX,[R] + MOV CL,32 + SUB CL,[EDX].TPCDTable.Length + MOV EAX,1 + SHL EAX,CL + DEC EAX + NOT EAX + MOV [EDX].TPCDTable.Mask,EAX + end; + Inc(R); + end; + PCDLength[I]:=Length; + end; + // initialize range limits + GetMem(RangeLimit,3*256); + try + for I:=0 to 255 do + begin + RangeLimit[I]:=0; + RangeLimit[I+256]:=I; + RangeLimit[I+2*256]:=255; + end; + Inc(PByte(RangeLimit),255); + // search for sync byte + PCDGetBits(16); + PCDGetBits(16); + while (Accumulator and $00FFF000)<>$00FFF000 do PCDGetBits(8); + while (Accumulator and $FFFFFF00)<>$FFFFFE00 do PCDGetBits(1); + // recover the Huffman encoded luminance and chrominance deltas + Length:=0; + Plane:=0; + Q:=Luma; + repeat + if (Accumulator and $FFFFFF00)=$FFFFFE00 then + begin + // determine plane and row number + PCDGetBits(16); + Row:=(Accumulator shr 9) and $1FFF; + if Row=Height then Break; + PCDGetBits(8); + Plane:=Accumulator shr 30; + PCDGetBits(16); + case Plane of + 0: Q:=Luma+Row*Width; + 2: begin + Q:=Chroma1+(Row shr 1)*Width; + Dec(Plane); + end; + 3: begin + Q:=Chroma2+(Row shr 1)*Width; + Dec(Plane); + end; + else Abort; // invalid/corrupt image + end; + Length:=PCDLength[Plane]; + Continue; + end; + // decode luminance or chrominance deltas + R:=PCDTable[Plane]; + I:=0; + while (IR.Sequence) do + begin + Inc(I); + Inc(R); + end; + if R=nil then + begin + // corrupt PCD image, skipping to sync byte + while (Accumulator and $00FFF000)<>$00FFF000 do PCDGetBits(8); + while (Accumulator and $FFFFFF00)<>$FFFFFE00 do PCDGetBits(1); + Continue; + end; + if R.Key<128 then Q^:=Char(RangeLimit[ClampByte(Byte(Q^)+R.Key)]) else Q^:=Char(RangeLimit[ClampByte(Byte(Q^)+R.Key-256)]); + Inc(Q); + PCDGetBits(R.Length); + until False; + finally + for I:=0 to 2 do if Assigned(PCDTable[I]) then FreeMem(PCDTable[I]); + Dec(PByte(RangeLimit), 255); + if Assigned(RangeLimit) then FreeMem(RangeLimit); + end; + finally + if Assigned(Buffer) then FreeMem(Buffer); + end; +end; + +end. + diff --git a/Addons/KOLGraphicEx.pas b/Addons/KOLGraphicEx.pas new file mode 100644 index 0000000..e5ac5e7 --- /dev/null +++ b/Addons/KOLGraphicEx.pas @@ -0,0 +1,6073 @@ +unit KOLGraphicEx; + +// (c) Copyright 1999, 2000 Dipl. Ing. Mike Lischke (public@lischke-online.de). All rights reserved. +// +// This package is freeware for non-commercial use only. +// Contact author for licenses (shareware@lischke-online.de) and see License.txt which comes with the package. +// +// GraphicEx - +// This unit is an addendum to Graphics.pas, in order to enable your application +// to import many common graphic files. +// +// See help file for a description of supported image types. Additionally, there is a resample routine +// (Stretch) based on code from Anders Melander (http://www.melander.dk/delphi/resampler/index.html) +// which has been optimized quite a lot to work faster and bug fixed. +// +// version - 9.9 +// +// 03-SEP-2000 ml: +// EPS with alpha channel, workaround for TIFs with wrong alpha channel indication, +// workaround for bad packbits compressed (TIF) images +// 28-AUG-2000 ml: +// small bugfixes +// 27-AUG-2000 ml: +// changed all FreeMemory(P) calls back to ... if Assigned(P) then FreeMem(P); ... +// 24-AUG-2000 ml: +// small bug in LZ77 decoder removed +// 18-AUG-2000 ml: +// TIF deflate decoding scheme +// 15-AUG-2000 ml: +// workaround for TIF images without compression, but prediction scheme set (which is not really used in this case) +// 12-AUG-2000 ml: +// small changes +// +// For older history please look into the help file. +// +// Note: The library provides usually only load support for the listed image formats but will perhaps be enhanced +// in the future to save those types too. It can be compiled with Delphi 4 or newer versions. +// +// +// (c) Copyright 1999, 2000 Dipl. Ing. Mike Lischke (public@lischke-online.de). All rights reserved. +// +// This package is freeware for non-commercial use only! +// Contact author for licenses (shareware@lischke-online.de) and see License.txt which comes with the package. + +////////////////////////////////////////////////// +// Converted to KOL by Dimaxx (dimaxx@atnet.ru) // +////////////////////////////////////////////////// + +interface + +{$ALIGN OFF} + +uses Windows, KOL, Err, KOLGraphicCompression, KOLGraphicColor, Errors; + +type + TCardinalArray = array of cardinal; + PDWORDArray = ^TDWORDArray; + TDWORDArray = array[0..65535] of cardinal; + TByteArray = array of byte; + TFloatArray = array of single; + + TImageOptions = set of ( + ioTiled, // image consists of tiles not strips (TIF) + ioBigEndian, // byte order in values >= words is reversed (TIF, RLA, SGI) + ioMinIsWhite, // minimum value in grayscale palette is white not black (TIF) + ioReversed, // bit order in bytes is reveresed (TIF) + ioUseGamma // gamma correction is used + ); + + // describes the compression used in the image file + TCompressionType = ( + ctUnknown, // compression type is unknown + ctNone, // no compression at all + ctRLE, // run length encoding + ctPackedBits, // Macintosh packed bits + ctLZW, // Lempel-Zif-Welch + ctFax3, // CCITT T.4 (1d), also known as fax group 3 + ctFaxRLE, // modified Huffman (CCITT T.4 derivative) + ctFax4, // CCITT T.6, also known as fax group 4 + ctFaxRLEW, // CCITT T.4 with word alignment + ctLZ77, // Huffman inflate/deflate + ctJPEG, // TIF JPEG compression (new version) + ctOJPEG, // TIF JPEG compression (old version) + ctThunderscan, // TIF thunderscan compression + ctNext, + ctIT8CTPAD, + ctIT8LW, + ctIT8MP, + ctIT8BL, + ctPixarFilm, + ctPixarLog, + ctDCS, + ctJBIG, + ctPCDHuffmann // PhotoCD Hufman compression + ); + + // properties of a particular image which are set while loading an image or when + // they are explicitly requested via ReadImageProperties + PImageProperties = ^TImageProperties; + TImageProperties = packed record + Version: cardinal; // TIF, PSP, GIF + Options: TImageOptions; // all images + Width, // all images + Height: cardinal; // all images + ColorScheme: TColorScheme; // all images + BitsPerSample, // all Images + SamplesPerPixel, // all images + BitsPerPixel: byte; // all images + Compression: TCompressionType; // all images + FileGamma: single; // RLA, PNG + XResolution, + YResolution: single; // given in dpi (TIF, PCX, PSP) + Interlaced, // GIF, PNG + HasAlpha: boolean; // TIF, PNG + + // informational data, used internally and/or by decoders + // TIF + FirstIFD, + PlanarConfig, // most of this data is needed in the JPG decoder + CurrentRow, + TileWidth, + TileLength, + BytesPerLine: cardinal; + RowsPerStrip: TCardinalArray; + YCbCrSubSampling, + JPEGTables: TByteArray; + JPEGColorMode, + JPEGTablesMode: Cardinal; + CurrentStrip, + StripCount, + Predictor: integer; + // PCD + Overview: boolean; // true if image is an overview image + Rotate: byte; // describes how the image is rotated (aka landscape vs. portrait image) + ImageCount: word; // number of subimages if this is an overview image + // GIF + LocalColorTable: boolean; // image uses an own color palette instead of the global one + // RLA + BottomUp: boolean; // images is bottom to top + // PSD + Channels: byte; // up to 24 channels per image + // PNG + FilterMode: byte; + end; + + // This is the general base class for all image types implemented in GraphicEx. + // It contains some generally used class/data. + PGraphicExGraphic = ^TGraphicExGraphic; + TGraphicExGraphic = class + private + FColorManager: PColorManager; + FImageProperties: TImageProperties; + FBasePosition: cardinal; // stream start position + FStream: PStream; // used for local references of the stream the class is currently loading from + FBitmap: PBitmap; + public + constructor Create; + destructor Destroy; + class function CanLoad(const Filename: string): boolean; overload; virtual; + class function CanLoad(Stream: PStream): boolean; overload; virtual; + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; virtual; + property Bitmap: PBitmap read FBitmap; + property ColorManager: PColorManager read FColorManager; + property ImageProperties: TImageProperties read FImageProperties write FImageProperties; + end; + + TGraphicExGraphicClass = class of TGraphicExGraphic; + + // *.bw, *.rgb, *.rgba, *.sgi images + TSGIGraphic = class(TGraphicExGraphic) + private + FRowStart, + FRowSize: PDWORDArray; // start and length of a line (if compressed) + FDecoder: TDecoder; // ...same applies here + procedure ReadAndDecode(Red,Green,Blue,Alpha: pointer; Row,BPC: cardinal); + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; + end; + + // *.cel, *.pic images + TAutodeskGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.tif, *.tiff images + // one entry in a an IFD (image file directory) + TIFDEntry = packed record + Tag: word; + DataType: word; + DataLength: cardinal; + Offset: cardinal; + end; + + TTIFFPalette = array[0..787] of word; + + TTIFFGraphic = class(TGraphicExGraphic) + private + FIFD: array of TIFDEntry; // the tags of one image file directory + FPalette: TTIFFPalette; + FYCbCrPositioning: cardinal; + FYCbCrCoefficients: TFloatArray; + function FindTag(Tag: cardinal; var Index: cardinal): boolean; + procedure GetValueList(Stream: PStream; Tag: cardinal; var Values: TByteArray); overload; + procedure GetValueList(Stream: PStream; Tag: cardinal; var Values: TCardinalArray); overload; + procedure GetValueList(Stream: PStream; Tag: cardinal; var Values: TFloatArray); overload; + function GetValue(Stream: PStream; Tag: cardinal; Default: single = 0): single; overload; + function GetValue(Tag: cardinal; Default: cardinal = 0): Cardinal; overload; + function GetValue(Tag: cardinal; var Size: cardinal; Default: cardinal = 0): cardinal; overload; + procedure SortIFD; + procedure SwapIFD; + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + TEPSGraphic = class(TTIFFGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.tga; *.vst; *.icb; *.vda; *.win images + TTGAGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.pcx; *.pcc; *.scr images + // Note: Due to the badly designed format a PCX/SCR file cannot be part in a larger stream because the position of the + // color palette as well as the decoding size can only be determined by the size of the image. + // Hence the image must be the only one in the stream or the last one. + TPCXGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.pcd images + // Note: By default the BASE resolution of a PCD image is loaded with LoadFromStream. + TPCDGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.ppm, *.pgm, *.pbm images + TPPMGraphic = class(TGraphicExGraphic) + private + FBuffer: array[0..4095] of Char; + FIndex: integer; + function CurrentChar: Char; + function GetChar: Char; + function GetNumber: cardinal; + function ReadLine: string; + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.cut (+ *.pal) images + // Note: Also this format should not be used in a stream unless it is the only image or the last one! + TCUTGraphic = class(TGraphicExGraphic) + private + FPaletteFile: string; + protected + procedure LoadPalette; + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + property PaletteFile: string read FPaletteFile write FPaletteFile; + end; + + // *.gif images + TGIFGraphic = class(TGraphicExGraphic) + private + function SkipExtensions: byte; + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.rla, *.rpf images + // implementation based on code from Dipl. Ing. Ingo Neumann (ingo@upstart.de, ingo_n@dialup.nacamar.de) + TRLAGraphic = class(TGraphicExGraphic) + private + procedure SwapHeader(var Header); // start position of the image header in the stream + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.psd, *.pdd images + TPSDGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.psp images (file version 3 and 4) + TPSPGraphic = class(TGraphicExGraphic) + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + end; + + // *.png images + TChunkType = array[0..3] of Char; + + // This header is followed by a variable number of data bytes, which are followed by the CRC for this data. + // The actual size of this data is given by field length in the chunk header. + // CRC is Cardinal (4 byte unsigned integer). + TPNGChunkHeader = packed record + Length: cardinal; // size of data (entire chunk excluding itself, CRC and type) + ChunkType: TChunkType; + end; + + TPNGGraphic = class(TGraphicExGraphic) + private + FDecoder: TLZ77Decoder; + FIDATSize: integer; // remaining bytes in the current IDAT chunk + FRawBuffer, // buffer to load raw chunk data and to check CRC + FCurrentSource: pointer; // points into FRawBuffer for current position of decoding + FHeader: TPNGChunkHeader; // header of the current chunk + FCurrentCRC: cardinal; // running CRC for the current chunk + FSourceBPP: integer; // bits per pixel used in the file +// FPalette: HPALETTE; // used to hold the palette handle until we can set it finally after the pixel format + // has been set too (as this destroys the current palette) + FTransparency: TByteArray; // If the image is indexed then this array might contain alpha values (depends on file) + // each entry corresponding to the same palette index as the index in this array. + // For grayscale and RGB images FTransparentColor contains the (only) transparent + // color. + FTransparentColor: TColor; // transparent color for gray and RGB + FBackgroundColor: TColor; // index or color ref + procedure ApplyFilter(Filter: byte; Line,PrevLine,Target: PByte; BPP,BytesPerRow: integer); + function IsChunk(ChunkType: TChunkType): boolean; + function LoadAndSwapHeader: cardinal; + procedure LoadBackgroundColor(const Description); + procedure LoadIDAT(const Description); + procedure LoadTransparency(const Description); + procedure ReadDataAndCheckCRC; + procedure ReadRow(RowBuffer: pointer; BytesPerRow: integer); + function SetupColorDepth(ColorType,BitDepth: integer): integer; + public + class function CanLoad(Stream: PStream): boolean; override; + procedure LoadFromStream(Stream: PStream); + function ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; override; + property BackgroundColor: TColor read FBackgroundColor; + property Transparency: TByteArray read FTransparency; + end; + + // ---------- file format management stuff + TFormatType = ( + ftAnimation, // format contains an animation (like GIF or AVI) + ftLayered, // format supports multiple layers (like PSP, PSD) + ftMultiImage, // format can contain more than one image (like TIF or GIF) + ftRaster, // format is contains raster data (this is mainly used) + ftVector // format contains vector data (like DXF or PSP file version 4) + ); + TFormatTypes = set of TFormatType; + TFilterSortType = ( + fstNone, // do not sort entries, list them as they are registered + fstBoth, // sort entries first by description then by extension + fstDescription, // sort entries by description only + fstExtension // sort entries by extension only + ); + TFilterOption = ( + foCompact, // use the compact form in filter strings instead listing each extension on a separate line + foIncludeAll, // include the 'All image files' filter string + foIncludeExtension // add the extension to the description + ); + TFilterOptions = set of TFilterOption; + + // resampling support types + TResamplingFilter = (sfBox, sfTriangle, sfHermite, sfBell, sfSpline, sfLanczos3, sfMitchell); + + // Resampling support routines + procedure Stretch(NewWidth,NewHeight: cardinal; Filter: TResamplingFilter; Radius: single; Source,Target: PBitmap); overload; + procedure Stretch(NewWidth,NewHeight: cardinal; Filter: TResamplingFilter; Radius: single; Source: PBitmap); overload; + +var + Comp2Str: array[TCompressionType] of string = ( + 'Unknown','None','RLE','PackedBits','LZW','CCITT Fax3', + 'Huffman RLE','CCITT Fax4','Huffman RLE word align', + 'LZ77','JPEG','Old JPEG','Thunderscan','Next', + 'IT8CTPAD','IT8LW','IT8MP','IT8BL','PixarFilm','PixarLog','DCS','JBIG', + 'PCDHuffmann'); + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses KOLMath, MZLib; + +const + PNG = 'PNG'; + TIF = 'TIF/TIFF'; + +type + // resampling support types + TRGBInt = packed record + R,G,B: integer; + end; + PRGBWord = ^TRGBWord; + TRGBWord = packed record + R,G,B: word; + end; + PRGBAWord = ^TRGBAWord; + TRGBAWord = packed record + R,G,B,A: word; + end; + PBGR = ^TBGR; + TBGR = packed record + B,G,R: byte; + end; + PBGRA = ^TBGRA; + TBGRA = packed record + B,G,R,A: byte; + end; + PRGB = ^TRGB; + TRGB = packed record + R,G,B: byte; + end; + PRGBA = ^TRGBA; + TRGBA = packed record + R,G,B,A: byte; + end; + PPixelArray = ^TPixelArray; + TPixelArray = array[0..0] of TBGR; + TFilterFunction = function(Value: single): single; + + // contributor for a Pixel + PContributor = ^TContributor; + TContributor = packed record + Weight: integer; // Pixel Weight + Pixel: integer; // Source Pixel + end; + TContributors = array of TContributor; + + // list of source pixels contributing to a destination pixel + TContributorEntry = packed record + N: integer; + Contributors: TContributors; + end; + + TContributorList = array of TContributorEntry; + +const + DefaultFilterRadius: array[TResamplingFilter] of single = (0.5,1,1,1.5,2,3,2); + +threadvar // globally used cache for current image (speeds up resampling about 10%) + CurrentLineR: array of integer; + CurrentLineG: array of integer; + CurrentLineB: array of integer; + +function Rect(ALeft,ATop,ARight,ABottom: integer): TRect; +begin + with Result do + begin + Left:=ALeft; + Top:=ATop; + Right:=ARight; + Bottom:=ABottom; + end; +end; + +function StrLIComp(const Str1,Str2: PChar; MaxLen: cardinal): integer; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,EDX + MOV ESI,EAX + MOV EBX,ECX + XOR EAX,EAX + OR ECX,ECX + JE @@4 + REPNE SCASB + SUB EBX,ECX + MOV ECX,EBX + MOV EDI,EDX + XOR EDX,EDX +@@1: REPE CMPSB + JE @@4 + MOV AL,[ESI-1] + CMP AL,'a' + JB @@2 + CMP AL,'z' + JA @@2 + SUB AL,20H +@@2: MOV DL,[EDI-1] + CMP DL,'a' + JB @@3 + CMP DL,'z' + JA @@3 + SUB DL,20H +@@3: SUB EAX,EDX + JE @@1 +@@4: POP EBX + POP ESI + POP EDI +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure GraphicExError(Code: integer); overload; +var E: Exception; +begin + E:=Exception.Create(e_Custom,ErrorMsg[Code]); + E.ErrorCode:=Code; + raise E; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure GraphicExError(Code: integer; Args: array of const); overload; +var E: Exception; +begin + E:=Exception.CreateFmt(e_Custom,ErrorMsg[Code],Args); + E.ErrorCode:=Code; + raise E; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Upsample(Width,Height,ScaledWidth: cardinal; Pixels: PChar); +// Creates a new image that is a integral size greater than an existing one. +var X,Y: cardinal; + P,Q,R: PChar; +begin + for Y:=0 to pred(Height) do + begin + P:=Pixels+(Height-1-Y)*ScaledWidth+(Width-1); + Q:=Pixels+((Height-1-Y) shl 1)*ScaledWidth+((Width-1) shl 1); + Q^:=P^; + (Q+1)^:=P^; + for X:=1 to pred(Width) do + begin + Dec(P); + Dec(Q,2); + Q^:=P^; + (Q+1)^:=Char((Word(P^)+Word((P+1)^)+1) shr 1); + end; + end; + for Y:=0 to Height-2 do + begin + P:=Pixels+(Y shl 1)*ScaledWidth; + Q:=P+ScaledWidth; + R:=Q+ScaledWidth; + for X:=0 to Width-2 do + begin + Q^:=Char((Word(P^)+Word(R^)+1) shr 1); + (Q+1)^:=Char((Word(P^)+Word((P+2)^)+Word(R^)+Word((R+2)^)+2) shr 2); + Inc(Q,2); + Inc(P,2); + Inc(R,2); + end; + Q^:=Char((Word(P^)+Word(R^)+1) shr 1); + Inc(P); + Inc(Q); + Q^:=Char((Word(P^)+Word(R^)+1) shr 1); + end; + P:=Pixels+(2*Height-2)*ScaledWidth; + Q:=Pixels+(2*Height-1)*ScaledWidth; + Move(P^,Q^,2*Width); +end; + +//----------------- filter functions for stretching -------------------------------------------------------------------- + +function HermiteFilter(Value: single): single; +// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 +begin + if Value<0 then Value:=-Value; + if Value<1 then Result:=(2*Value-3)*Sqr(Value)+1 else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function BoxFilter(Value: Single): Single; +// This filter is also known as 'nearest neighbour' Filter. +begin + if (Value>-0.5) and (Value<=0.5) then Result:=1 else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TriangleFilter(Value: single): single; +// aka 'linear' or 'bilinear' filter +begin + if Value<0 then Value:=-Value; + if Value<1 then Result:=1-Value else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function BellFilter(Value: single): single; +begin + if Value<0 then Value:=-Value; + if Value<0.5 then Result:=0.75-Sqr(Value) else + if Value<1.5 then + begin + Value:=Value-1.5; + Result:=0.5*Sqr(Value); + end + else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function SplineFilter(Value: single): single; +// B-spline filter +var Temp: single; +begin + if Value<0 then Value:=-Value; + if Value<1 then + begin + Temp:=Sqr(Value); + Result:=0.5*Temp*Value-Temp+2/3; + end + else + if Value<2 then + begin + Value:=2-Value; + Result:=Sqr(Value)*Value/6; + end + else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function Lanczos3Filter(Value: single): single; + //--------------- local function -------------------------------------------- + function SinC(Value: single): single; + begin + if Value<>0 then + begin + Value:=Value*PI; + Result:=Sin(Value)/Value; + end + else Result:=1; + end; + //--------------------------------------------------------------------------- +begin + if Value<0 then Value:=-Value; + if Value<3 then Result:=SinC(Value)*SinC(Value/3) else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function MitchellFilter(Value: single): single; +var Temp,B,C: single; +begin + B:=1/3; + C:=1/3; + if Value<0 then Value:=-Value; + Temp:=Sqr(Value); + if Value<1 then + begin + Value:=(((12-9*B-6*C)*(Value*Temp))+((-18+12*B+6*C)*Temp)+(6-2*B)); + Result:=Value/6; + end + else + if Value<2 then + begin + Value:=(((-B-6*C)*(Value*Temp))+((6*B+30*C)*Temp)+((-12*B-48*C)*Value)+(8*B+24*C)); + Result:=Value/6; + end + else Result:=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +const + FilterList: array[TResamplingFilter] of TFilterFunction = ( + BoxFilter,TriangleFilter,HermiteFilter,BellFilter, + SplineFilter,Lanczos3Filter,MitchellFilter); + +//---------------------------------------------------------------------------------------------------------------------- + +procedure FillLineChache(N,Delta: integer; Line: pointer); +var I: integer; + Run: PBGR; +begin + Run:=Line; + for I:=0 to pred(N) do + begin + CurrentLineR[I]:=Run.R; + CurrentLineG[I]:=Run.G; + CurrentLineB[I]:=Run.B; + Inc(PByte(Run),Delta); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function ApplyContributors(N: integer; Contributors: TContributors): TBGR; +var RGB: TRGBInt; + J,Total,Weight: integer; + Pixel: cardinal; + Contr: ^TContributor; +begin + RGB.R:=0; + RGB.G:=0; + RGB.B:=0; + Total:=0; + Contr:=@Contributors[0]; + for J:=0 to pred(N) do + begin + Weight:=Contr.Weight; + Inc(Total,Weight); + Pixel:=Contr.Pixel; + Inc(RGB.R,CurrentLineR[Pixel]*Weight); + Inc(RGB.G,CurrentLineG[Pixel]*Weight); + Inc(RGB.B,CurrentLineB[Pixel]*Weight); + Inc(Contr); + end; + if Total=0 then + begin + Result.R:=ClampByte(RGB.R shr 8); + Result.G:=ClampByte(RGB.G shr 8); + Result.B:=ClampByte(RGB.B shr 8); + end + else + begin + Result.R:=ClampByte(RGB.R div Total); + Result.G:=ClampByte(RGB.G div Total); + Result.B:=ClampByte(RGB.B div Total); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DoStretch(Filter: TFilterFunction; Radius: single; Source,Target: PBitmap); +// This is the actual scaling routine. Target must be allocated already with sufficient size. Source must +// contain valid data, Radius must not be 0 and Filter must not be nil. +var ScaleX,ScaleY: single; // Zoom scale factors + I,J,K,N: integer; // Loop variables + Center: single; // Filter calculation variables + Width: single; + Weight: integer; // Filter calculation variables + Left, + Right: integer; // Filter calculation variables + Work: PBitmap; + ContributorList: TContributorList; + SourceLine,DestLine: PPixelArray; + DestPixel: PBGR; + Delta,DestDelta: integer; + SourceHeight,SourceWidth,TargetHeight,TargetWidth: integer; +begin + // shortcut variables + SourceHeight:=Source.Height; + SourceWidth:=Source.Width; + TargetHeight:=Target.Height; + TargetWidth:=Target.Width; + if (SourceHeight=0) or (SourceWidth=0) or (TargetHeight=0) or (TargetWidth=0) then Exit; + // create intermediate image to hold horizontal zoom + Work:=NewBitmap(0,0); + try + Work.PixelFormat:=pf24Bit; + Work.Height:=SourceHeight; + Work.Width:=TargetWidth; + if SourceWidth=1 then ScaleX:=TargetWidth/SourceWidth else ScaleX:=(TargetWidth-1)/(SourceWidth-1); + if (SourceHeight=1) or (TargetHeight=1) then ScaleY:=TargetHeight/SourceHeight else ScaleY:=(TargetHeight-1)/(SourceHeight-1); + // pre-calculate filter contributions for a row + SetLength(ContributorList,TargetWidth); + // horizontal sub-sampling + if ScaleX<1 then + begin + // scales from bigger to smaller Width + Width:=Radius/ScaleX; + for I:=0 to pred(TargetWidth) do + begin + ContributorList[I].N:=0; + SetLength(ContributorList[I].Contributors,Trunc(2*Width+1)); + Center:=I/ScaleX; + Left:=Floor(Center-Width); + Right:=Ceil(Center+Width); + for J:=Left to Right do + begin + Weight:=Round(Filter((Center-J)*ScaleX)*ScaleX*256); + if Weight<>0 then + begin + if J<0 then N:=-J else + if J>=SourceWidth then N:=SourceWidth-J+SourceWidth-1 else N:=J; + K:=ContributorList[I].N; + Inc(ContributorList[I].N); + ContributorList[I].Contributors[K].Pixel:=N; + ContributorList[I].Contributors[K].Weight:=Weight; + end; + end; + end; + end + else + begin + // horizontal super-sampling + // scales from smaller to bigger Width + for I:=0 to pred(TargetWidth) do + begin + ContributorList[I].N:=0; + SetLength(ContributorList[I].Contributors,Trunc(2*Radius+1)); + Center:=I/ScaleX; + Left:=Floor(Center-Radius); + Right:=Ceil(Center+Radius); + for J:=Left to Right do + begin + Weight:=Round(Filter(Center-J)*256); + if Weight<>0 then + begin + if J<0 then N:=-J else + if J>=SourceWidth then N:=SourceWidth-J+SourceWidth-1 else N:=J; + K:=ContributorList[I].N; + Inc(ContributorList[I].N); + ContributorList[I].Contributors[K].Pixel:=N; + ContributorList[I].Contributors[K].Weight:=Weight; + end; + end; + end; + end; + // now apply filter to sample horizontally from Src to Work + SetLength(CurrentLineR,SourceWidth); + SetLength(CurrentLineG,SourceWidth); + SetLength(CurrentLineB,SourceWidth); + for K:=0 to pred(SourceHeight) do + begin + SourceLine:=Source.ScanLine[K]; + FillLineChache(SourceWidth,3,SourceLine); + DestPixel:=Work.ScanLine[K]; + for I:=0 to pred(TargetWidth) do + with ContributorList[I] do + begin + DestPixel^:=ApplyContributors(N,ContributorList[I].Contributors); + // move on to next column + Inc(DestPixel); + end; + end; + // free the memory allocated for horizontal filter weights, since we need the stucture again + for I:=0 to pred(TargetWidth) do ContributorList[I].Contributors:=nil; + ContributorList:=nil; + // pre-calculate filter contributions for a column + SetLength(ContributorList,TargetHeight); + // vertical sub-sampling + if ScaleY<1 then + begin + // scales from bigger to smaller height + Width:=Radius/ScaleY; + for I:=0 to pred(TargetHeight) do + begin + ContributorList[I].N:=0; + SetLength(ContributorList[I].Contributors,Trunc(2*Width+1)); + Center:=I/ScaleY; + Left:=Floor(Center-Width); + Right:=Ceil(Center+Width); + for J:=Left to Right do + begin + Weight:=Round(Filter((Center-J)*ScaleY)*ScaleY*256); + if Weight<>0 then + begin + if J<0 then N:=-J else + if J>=SourceHeight then N:=SourceHeight-J+SourceHeight-1 else N:=J; + K:=ContributorList[I].N; + Inc(ContributorList[I].N); + ContributorList[I].Contributors[K].Pixel:=N; + ContributorList[I].Contributors[K].Weight:=Weight; + end; + end; + end + end + else + begin + // vertical super-sampling + // scales from smaller to bigger height + for I:=0 to pred(TargetHeight) do + begin + ContributorList[I].N:=0; + SetLength(ContributorList[I].Contributors,Trunc(2*Radius+1)); + Center:=I/ScaleY; + Left:=Floor(Center-Radius); + Right:=Ceil(Center+Radius); + for J:=Left to Right do + begin + Weight:=Round(Filter(Center-J)*256); + if Weight<>0 then + begin + if J<0 then N:=-J else + if J>=SourceHeight then N:=SourceHeight-J+SourceHeight-1 else N:=J; + K:=ContributorList[I].N; + Inc(ContributorList[I].N); + ContributorList[I].Contributors[K].Pixel:=N; + ContributorList[I].Contributors[K].Weight:=Weight; + end; + end; + end; + end; + // apply filter to sample vertically from Work to Target + SetLength(CurrentLineR,SourceHeight); + SetLength(CurrentLineG,SourceHeight); + SetLength(CurrentLineB,SourceHeight); + SourceLine:=Work.ScanLine[0]; + Delta:=Integer(Work.ScanLine[1])-Integer(SourceLine); + DestLine:=Target.ScanLine[0]; + DestDelta:=Integer(Target.ScanLine[1])-Integer(DestLine); + for K:=0 to pred(TargetWidth) do + begin + DestPixel:=Pointer(DestLine); + FillLineChache(SourceHeight,Delta,SourceLine); + for I:=0 to pred(TargetHeight) do + with ContributorList[I] do + begin + DestPixel^:=ApplyContributors(N,ContributorList[I].Contributors); + Inc(Integer(DestPixel),DestDelta); + end; + Inc(SourceLine); + Inc(DestLine); + end; + // free the memory allocated for vertical filter weights + for I:=0 to pred(TargetHeight) do ContributorList[I].Contributors:=nil; + // this one is done automatically on exit, but is here for completeness + ContributorList:=nil; + finally + Work.Free; + CurrentLineR:=nil; + CurrentLineG:=nil; + CurrentLineB:=nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Stretch(NewWidth,NewHeight: cardinal; Filter: TResamplingFilter; Radius: single; Source,Target: PBitmap); +// Scales the source bitmap to the given size (NewWidth, NewHeight) and stores the Result in Target. +// Filter describes the filter function to be applied and Radius the size of the filter area. +// Is Radius = 0 then the recommended filter area will be used (see DefaultFilterRadius). +begin + if Radius=0 then Radius:=DefaultFilterRadius[Filter]; + Target.Handle:=0; + Target.PixelFormat:=pf24Bit; + Target.Width:=NewWidth; + Target.Height:=NewHeight; + Source.PixelFormat:=pf24Bit; + DoStretch(FilterList[Filter],Radius,Source,Target); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Stretch(NewWidth,NewHeight: cardinal; Filter: TResamplingFilter; Radius: single; Source: PBitmap); +var Target: PBitmap; +begin + if Radius=0 then Radius:=DefaultFilterRadius[Filter]; + Target:=NewBitmap(0,0); + try + Target.PixelFormat:=pf24Bit; + Target.Width:=NewWidth; + Target.Height:=NewHeight; + Source.PixelFormat:=pf24Bit; + DoStretch(FilterList[Filter],Radius,Source,Target); + Source.Assign(Target); + finally + Target.Free; + end; +end; + +//----------------- support functions for image loading ---------------------------------------------------------------- + +procedure SwapShort(P: PWord; Count: cardinal); +// swaps high and low byte of 16 bit values +// EAX contains P, EDX contains Count +asm +@@Loop: + MOV CX,[EAX] + XCHG CH,CL + MOV [EAX],CX + ADD EAX,2 + DEC EDX + JNZ @@Loop +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure SwapLong(P: PInteger; Count: cardinal); overload; +// swaps high and low bytes of 32 bit values +// EAX contains P, EDX contains Count +asm +@@Loop: + MOV ECX,[EAX] + BSWAP ECX + MOV [EAX],ECX + ADD EAX,4 + DEC EDX + JNZ @@Loop +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function SwapLong(Value: cardinal): cardinal; overload; +// swaps high and low bytes of the given 32 bit value +asm + BSWAP EAX +end; + +//----------------- various conversion routines ------------------------------------------------------------------------ + +procedure Depredict1(P: pointer; Count: cardinal); +// EAX contains P and EDX Count +asm +@@1: + MOV CL,[EAX] + ADD [EAX+1],CL + INC EAX + DEC EDX + JNZ @@1 +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Depredict3(P: pointer; Count: cardinal); +// EAX contains P and EDX Count +asm + MOV ECX,EDX + SHL ECX,1 + ADD ECX,EDX // 3*Count +@@1: + MOV DL,[EAX] + ADD [EAX+3],DL + INC EAX + DEC ECX + JNZ @@1 +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Depredict4(P: pointer; Count: cardinal); +// EAX contains P and EDX Count +asm + SHL EDX,2 // 4*Count +@@1: + MOV CL,[EAX] + ADD [EAX+4],CL + INC EAX + DEC EDX + JNZ @@1 +end; + +//----------------- TGraphicExGraphic ---------------------------------------------------------------------------------- + +constructor TGraphicExGraphic.Create; +begin + inherited; + FColorManager:=NewColorManager; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TGraphicExGraphic.Destroy; +begin + FColorManager.Free; + if Assigned(FBitmap) then FBitmap.Free; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TGraphicExGraphic.CanLoad(const Filename: string): boolean; +var Stream: PStream; +begin + Stream:=NewReadFileStream(Filename); + try + Result:=CanLoad(Stream); + finally + Stream.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TGraphicExGraphic.CanLoad(Stream: PStream): boolean; +// Descentants have to override this method and return True if they consider the data in Stream +// as loadable by the particular class. +// Note: Make sure the stream position is the same on exit as it was on enter! +begin + Result:=False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TGraphicExGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +// Initializes the internal image properties structure. +// Descentants must override this method to fill in the actual values. +// Result is always False to show there is no image to load. +begin + Finalize(FImageProperties); + ZeroMemory(@FImageProperties,sizeof(FImageProperties)); + FImageProperties.FileGamma:=1; + Result:=False; +end; + +//----------------- TAutodeskGraphic ----------------------------------------------------------------------------------- + +type + TAutodeskHeader = packed record + Width,Height,XCoord,YCoord: word; + Depth,Compression: byte; + DataSize: cardinal; + Reserved: array[0..15] of byte; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TAutodeskGraphic.CanLoad(Stream: PStream): boolean; +var FileID: word; + Header: TAutodeskHeader; + LastPosition: cardinal; +begin + Result:=(Stream.Size-Stream.Position)>(sizeof(FileID)+sizeof(Header)); + if Result then + begin + LastPosition:=Stream.Position; + Stream.Read(FileID,sizeof(FileID)); + Result:=FileID=$9119; + if Result then + begin + // read image dimensions + Stream.Read(Header,sizeof(Header)); + Result:=(Header.Depth=8) and (Header.Compression=0); + end; + Stream.Position:=LastPosition; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TAutodeskGraphic.LoadFromStream(Stream: PStream); +var FileID: word; + FileHeader: TAutodeskHeader; + I: integer; + Pal: array[0..767] of byte; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + Stream.Position:=FBasePosition; + Stream.Read(FileID,2); + // read image dimensions + Stream.Read(FileHeader,sizeof(FileHeader)); + // read palette data + Stream.Read(Pal,sizeof(Pal)); + // setup bitmap properties + FBitmap:=NewBitmap(FileHeader.Width,FileHeader.Height); + FBitmap.PixelFormat:=pf8Bit; + // assign palette data + for I:=0 to 255 do + FBitmap.DIBPalEntries[I]:=RGB(Pal[I*3+2] shl 2,Pal[I*3+1] shl 2,Pal[I*3] shl 2); + // finally read image data + for I:=0 to pred(FBitmap.Height) do Stream.Read(FBitmap.ScanLine[I]^,FileHeader.Width); + end + else GraphicExError(1{gesInvalidImage},['Autodesk']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TAutodeskGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var FileID: word; + Header: TAutodeskHeader; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(FileID,2); + if FileID=$9119 then + begin + // read image dimensions + Stream.Read(Header,sizeof(Header)); + ColorScheme:=csIndexed; + Width:=Header.Width; + Height:=Header.Height; + BitsPerSample:=8; + SamplesPerPixel:=1; + BitsPerPixel:=8; + Compression:=ctNone; + Result:=True; + end; + end; +end; + +//----------------- TSGIGraphic ---------------------------------------------------------------------------------------- + +const + SGIMagic = 474; + SGI_COMPRESSION_VERBATIM = 0; + SGI_COMPRESSION_RLE = 1; + +type + TSGIHeader = packed record + Magic: smallint; // IRIS image file magic number + Storage, // Storage format + BPC: byte; // Number of bytes per pixel channel (1 or 2) + Dimension: word; // Number of dimensions + // 1 - one single scanline (and one channel) of length XSize + // 2 - two dimensional (one channel) of size XSize x YSize + // 3 - three dimensional (ZSize channels) of size XSize x YSize + XSize, // width of image + YSize, // height of image + ZSize: word; // number of channels/planes in image (3 for RGB, 4 for RGBA etc.) + PixMin, // Minimum pixel value + PixMax: cardinal; // Maximum pixel value + Dummy: cardinal; // ignored + ImageName: array[0..79] of Char; + ColorMap: integer; // Colormap ID + // 0 - default, almost all images are stored with this flag + // 1 - dithered, only one channel of data (pixels are packed), obsolete + // 2 - screen (palette) image, obsolete + // 3 - no image data, palette only, not displayable + Dummy2: array[0..403] of byte; // ignored + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TSGIGraphic.CanLoad(Stream: PStream): boolean; +// returns True if the data in Stream represents a graphic which can be loaded by this class +var Header: TSGIHeader; + LastPosition: cardinal; +begin + Result:=(Stream.Size-Stream.Position)>sizeof(TSGIHeader); + if Result then + begin + LastPosition:=Stream.Position; + Stream.Read(Header,sizeof(Header)); + // one number as check is too unreliable, hence we take some more fields into the check + Result:=(System.Swap(Header.Magic)=SGIMagic) and (Header.BPC in [1,2]) and (System.Swap(Header.Dimension) in [1..3]); + Stream.Position:=LastPosition; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TSGIGraphic.ReadAndDecode(Red,Green,Blue,Alpha: pointer; Row,BPC: cardinal); +var Count: cardinal; + RawBuffer: pointer; +begin + with FImageProperties do + // compressed image? + if Assigned(FDecoder) then + begin + if Assigned(Red) then + begin + FStream.Position:=FBasePosition+FRowStart[Row+0*Height]; + Count:=BPC*FRowSize[Row+0*Height]; + GetMem(RawBuffer,Count); + try + FStream.Read(RawBuffer^,Count); + FDecoder.Decode(RawBuffer,Red,Count,Width); + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end; + if Assigned(Green) then + begin + FStream.Position:=FBasePosition+FRowStart[Row+1*Height]; + Count:=BPC*FRowSize[Row+1*Height]; + GetMem(RawBuffer,Count); + try + FStream.Read(RawBuffer^,Count); + FDecoder.Decode(RawBuffer,Green,Count,Width); + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end; + if Assigned(Blue) then + begin + FStream.Position:=FBasePosition+FRowStart[Row+2*Height]; + Count:=BPC*FRowSize[Row+2*Height]; + GetMem(RawBuffer,Count); + try + FStream.Read(RawBuffer^,Count); + FDecoder.Decode(RawBuffer,Blue,Count,Width); + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end; + if Assigned(Alpha) then + begin + FStream.Position:=FBasePosition+FRowStart[Row+3*Height]; + Count:=BPC*FRowSize[Row+3*Height]; + GetMem(RawBuffer,Count); + try + FStream.Read(RawBuffer^,Count); + FDecoder.Decode(RawBuffer,Alpha,Count,Width); + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end; + end + else + begin + if Assigned(Red) then + begin + FStream.Position:=FBasePosition+512+(Row*Width); + FStream.Read(Red^,BPC*Width); + end; + if Assigned(Green) then + begin + FStream.Position:=FBasePosition+512+(Row*Width)+(Width*Height); + FStream.Read(Green^,BPC*Width); + end; + if Assigned(Blue) then + begin + FStream.Position:=FBasePosition+512+(Row*Width)+(2*Width*Height); + FStream.Read(Blue^,BPC*Width); + end; + if Assigned(Alpha) then + begin + FStream.Position:=FBasePosition+512+(Row*Width)+(3*Width*Height); + FStream.Read(Alpha^,BPC*Width); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TSGIGraphic.LoadFromStream(Stream: PStream); +var Y,Count: cardinal; + RedBuffer,GreenBuffer,BlueBuffer,AlphaBuffer: pointer; + Header: TSGIHeader; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + // keep stream reference and start position for seek operations + FStream:=Stream; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + Stream.Position:=FBasePosition; + // read header again, we need some additional information + Stream.Read(Header,sizeof(Header)); + // SGI images are always stored in big endian style + ColorManager.SourceOptions:=[coNeedByteSwap]; + with Header do ColorMap:=SwapLong(ColorMap); + if Compression=ctRLE then + begin + Count:=Height*SamplesPerPixel; + GetMem(FRowStart,Count*4); + GetMem(FRowSize,Count*4); + // read line starts and sizes from stream + Stream.Read(FRowStart^,Count*sizeof(Cardinal)); + SwapLong(Pointer(FRowStart),Count); + Stream.Read(FRowSize^,Count*sizeof(Cardinal)); + SwapLong(Pointer(FRowSize),Count); + FDecoder:=TSGIRLEDecoder.Create(BitsPerSample); + end + else + begin + FDecoder:=nil; + end; + // set pixel format before size to avoid possibly large conversion operation + ColorManager.SourceBitsPerSample:=BitsPerSample; + ColorManager.TargetBitsPerSample:=8; + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + ColorManager.SourceColorScheme:=ColorScheme; + case ColorScheme of + csRGBA: ColorManager.TargetColorScheme:=csBGRA; + csRGB: ColorManager.TargetColorScheme:=csBGR; + else ColorManager.TargetColorScheme:=csIndexed; + end; + FBitmap:=NewBitmap(Width,Height); + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + RedBuffer:=nil; + GreenBuffer:=nil; + BlueBuffer:=nil; + AlphaBuffer:=nil; + try + Count:=(BitsPerPixel div 8)*Width; + // read lines and put them into the bitmap + case ColorScheme of + csRGBA: + begin + GetMem(RedBuffer,Count); + GetMem(GreenBuffer,Count); + GetMem(BlueBuffer,Count); + GetMem(AlphaBuffer,Count); + for Y:=0 to pred(Height) do + begin + ReadAndDecode(RedBuffer,GreenBuffer,BlueBuffer,AlphaBuffer,Y,Header.BPC); + ColorManager.ConvertRow([RedBuffer,GreenBuffer,BlueBuffer,AlphaBuffer],FBitmap.ScanLine[Height-Y-1],Width,$FF); + end; + end; + csRGB: + begin + GetMem(RedBuffer,Count); + GetMem(GreenBuffer,Count); + GetMem(BlueBuffer,Count); + for Y:=0 to pred(Height) do + begin + ReadAndDecode(RedBuffer,GreenBuffer,BlueBuffer,nil,Y,Header.BPC); + ColorManager.ConvertRow([RedBuffer,GreenBuffer,BlueBuffer],FBitmap.ScanLine[Height-Y-1],Width,$FF); + end; + end; + else + // any other format is interpreted as being 256 gray scales + ColorManager.CreateGrayscalePalette(FBitmap,False); + for Y:=0 to pred(Height) do + begin + ReadAndDecode(FBitmap.ScanLine[Height-Y-1],nil,nil,nil,Y,Header.BPC); + end; + end; + finally + if Assigned(RedBuffer) then FreeMem(RedBuffer); + if Assigned(GreenBuffer) then FreeMem(GreenBuffer); + if Assigned(BlueBuffer) then FreeMem(BlueBuffer); + if Assigned(AlphaBuffer) then FreeMem(AlphaBuffer); + FDecoder.Free; + end; + end; + end + else GraphicExError(1{gesInvalidImage},['SGI, BW or RGB(A)']); + FreeMem(FRowStart,Count*4); + FreeMem(FRowSize,Count*4); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TSGIGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TSGIHeader; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(Header,sizeof(Header)); + if System.Swap(Header.Magic)=SGIMagic then + begin + Options:=[ioBigEndian]; + BitsPerSample:=Header.BPC*8; + Width:=System.Swap(Header.XSize); + Height:=System.Swap(Header.YSize); + SamplesPerPixel:=System.Swap(Header.ZSize); + case SamplesPerPixel of + 4: ColorScheme:=csRGBA; + 3: ColorScheme:=csRGB; + else + // all other is considered as being 8 bit gray scale + ColorScheme:=csIndexed; + end; + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + if Header.Storage=SGI_COMPRESSION_RLE then Compression:=ctRLE else Compression:=ctNone; + Result:=True; + end; + end; +end; + +//----------------- TTIFFGraphic --------------------------------------------------------------------------------------- + +const // TIFF tags + TIFFTAG_SUBFILETYPE = 254; // subfile data descriptor + FILETYPE_REDUCEDIMAGE = $1; // reduced resolution version + FILETYPE_PAGE = $2; // one page of many + FILETYPE_MASK = $4; // transparency mask + TIFFTAG_OSUBFILETYPE = 255; // kind of data in subfile (obsolete by revision 5.0) + OFILETYPE_IMAGE = 1; // full resolution image data + OFILETYPE_REDUCEDIMAGE = 2; // reduced size image data + OFILETYPE_PAGE = 3; // one page of many + TIFFTAG_IMAGEWIDTH = 256; // image width in pixels + TIFFTAG_IMAGELENGTH = 257; // image height in pixels + TIFFTAG_BITSPERSAMPLE = 258; // bits per channel (sample) + TIFFTAG_COMPRESSION = 259; // data compression technique + COMPRESSION_NONE = 1; // dump mode + COMPRESSION_CCITTRLE = 2; // CCITT modified Huffman RLE + COMPRESSION_CCITTFAX3 = 3; // CCITT Group 3 fax encoding + COMPRESSION_CCITTFAX4 = 4; // CCITT Group 4 fax encoding + COMPRESSION_LZW = 5; // Lempel-Ziv & Welch + COMPRESSION_OJPEG = 6; // 6.0 JPEG (old version) + COMPRESSION_JPEG = 7; // JPEG DCT compression (new version) + COMPRESSION_ADOBE_DEFLATE = 8; // new id but same as COMPRESSION_DEFLATE + COMPRESSION_NEXT = 32766; // next 2-bit RLE + COMPRESSION_CCITTRLEW = 32771; // modified Huffman with word alignment + COMPRESSION_PACKBITS = 32773; // Macintosh RLE + COMPRESSION_THUNDERSCAN = 32809; // ThunderScan RLE + // codes 32895-32898 are reserved for ANSI IT8 TIFF/IT + COMPRESSION_DCS = 32947; // Kodak DCS encoding + COMPRESSION_JBIG = 34661; // ISO JBIG + TIFFTAG_PHOTOMETRIC = 262; // photometric interpretation + PHOTOMETRIC_MINISWHITE = 0; // min value is white + PHOTOMETRIC_MINISBLACK = 1; // min value is black + PHOTOMETRIC_RGB = 2; // RGB color model + PHOTOMETRIC_PALETTE = 3; // color map indexed + PHOTOMETRIC_MASK = 4; // holdout mask + PHOTOMETRIC_SEPARATED = 5; // color separations + PHOTOMETRIC_YCBCR = 6; // CCIR 601 + PHOTOMETRIC_CIELAB = 8; // 1976 CIE L*a*b* + TIFFTAG_THRESHHOLDING = 263; // thresholding used on data (obsolete by revision 5.0) + THRESHHOLD_BILEVEL = 1; // b&w art scan + THRESHHOLD_HALFTONE = 2; // or dithered scan + THRESHHOLD_ERRORDIFFUSE = 3; // usually floyd-steinberg + TIFFTAG_CELLWIDTH = 264; // dithering matrix width (obsolete by revision 5.0) + TIFFTAG_CELLLENGTH = 265; // dithering matrix height (obsolete by revision 5.0) + TIFFTAG_FILLORDER = 266; // data order within a Byte + FILLORDER_MSB2LSB = 1; // most significant -> least + FILLORDER_LSB2MSB = 2; // least significant -> most + TIFFTAG_DOCUMENTNAME = 269; // name of doc. image is from + TIFFTAG_IMAGEDESCRIPTION = 270; // info about image + TIFFTAG_MAKE = 271; // scanner manufacturer name + TIFFTAG_MODEL = 272; // scanner model name/number + TIFFTAG_STRIPOFFSETS = 273; // Offsets to data strips + TIFFTAG_ORIENTATION = 274; // image FOrientation (obsolete by revision 5.0) + ORIENTATION_TOPLEFT = 1; // row 0 top, col 0 lhs + ORIENTATION_TOPRIGHT = 2; // row 0 top, col 0 rhs + ORIENTATION_BOTRIGHT = 3; // row 0 bottom, col 0 rhs + ORIENTATION_BOTLEFT = 4; // row 0 bottom, col 0 lhs + ORIENTATION_LEFTTOP = 5; // row 0 lhs, col 0 top + ORIENTATION_RIGHTTOP = 6; // row 0 rhs, col 0 top + ORIENTATION_RIGHTBOT = 7; // row 0 rhs, col 0 bottom + ORIENTATION_LEFTBOT = 8; // row 0 lhs, col 0 bottom + TIFFTAG_SAMPLESPERPIXEL = 277; // samples per pixel + TIFFTAG_ROWSPERSTRIP = 278; // rows per strip of data + TIFFTAG_STRIPBYTECOUNTS = 279; // bytes counts for strips + TIFFTAG_MINSAMPLEVALUE = 280; // minimum sample value (obsolete by revision 5.0) + TIFFTAG_MAXSAMPLEVALUE = 281; // maximum sample value (obsolete by revision 5.0) + TIFFTAG_XRESOLUTION = 282; // pixels/resolution in x + TIFFTAG_YRESOLUTION = 283; // pixels/resolution in y + TIFFTAG_PLANARCONFIG = 284; // storage organization + PLANARCONFIG_CONTIG = 1; // single image plane + PLANARCONFIG_SEPARATE = 2; // separate planes of data + TIFFTAG_PAGENAME = 285; // page name image is from + TIFFTAG_XPOSITION = 286; // x page offset of image lhs + TIFFTAG_YPOSITION = 287; // y page offset of image lhs + TIFFTAG_FREEOFFSETS = 288; // byte offset to free block (obsolete by revision 5.0) + TIFFTAG_FREEBYTECOUNTS = 289; // sizes of free blocks (obsolete by revision 5.0) + TIFFTAG_GRAYRESPONSEUNIT = 290; // gray scale curve accuracy + GRAYRESPONSEUNIT_10S = 1; // tenths of a unit + GRAYRESPONSEUNIT_100S = 2; // hundredths of a unit + GRAYRESPONSEUNIT_1000S = 3; // thousandths of a unit + GRAYRESPONSEUNIT_10000S = 4; // ten-thousandths of a unit + GRAYRESPONSEUNIT_100000S = 5; // hundred-thousandths + TIFFTAG_GRAYRESPONSECURVE = 291; // gray scale response curve + TIFFTAG_GROUP3OPTIONS = 292; // 32 flag bits + GROUP3OPT_2DENCODING = $1; // 2-dimensional coding + GROUP3OPT_UNCOMPRESSED = $2; // data not compressed + GROUP3OPT_FILLBITS = $4; // fill to byte boundary + TIFFTAG_GROUP4OPTIONS = 293; // 32 flag bits + GROUP4OPT_UNCOMPRESSED = $2; // data not compressed + TIFFTAG_RESOLUTIONUNIT = 296; // units of resolutions + RESUNIT_NONE = 1; // no meaningful units + RESUNIT_INCH = 2; // english + RESUNIT_CENTIMETER = 3; // metric + TIFFTAG_PAGENUMBER = 297; // page numbers of multi-page + TIFFTAG_COLORRESPONSEUNIT = 300; // color curve accuracy + COLORRESPONSEUNIT_10S = 1; // tenths of a unit + COLORRESPONSEUNIT_100S = 2; // hundredths of a unit + COLORRESPONSEUNIT_1000S = 3; // thousandths of a unit + COLORRESPONSEUNIT_10000S = 4; // ten-thousandths of a unit + COLORRESPONSEUNIT_100000S = 5; // hundred-thousandths + TIFFTAG_TRANSFERFUNCTION = 301; // colorimetry info + TIFFTAG_SOFTWARE = 305; // name & release + TIFFTAG_DATETIME = 306; // creation date and time + TIFFTAG_ARTIST = 315; // creator of image + TIFFTAG_HOSTCOMPUTER = 316; // machine where created + TIFFTAG_PREDICTOR = 317; // prediction scheme w/ LZW + PREDICTION_NONE = 1; // no prediction scheme used before coding + PREDICTION_HORZ_DIFFERENCING = 2; // horizontal differencing prediction scheme used + TIFFTAG_WHITEPOINT = 318; // image white point + TIFFTAG_PRIMARYCHROMATICITIES = 319; // primary chromaticities + TIFFTAG_COLORMAP = 320; // RGB map for pallette image + TIFFTAG_HALFTONEHINTS = 321; // highlight+shadow info + TIFFTAG_TILEWIDTH = 322; // rows/data tile + TIFFTAG_TILELENGTH = 323; // cols/data tile + TIFFTAG_TILEOFFSETS = 324; // offsets to data tiles + TIFFTAG_TILEBYTECOUNTS = 325; // Byte counts for tiles + TIFFTAG_BADFAXLINES = 326; // lines w/ wrong pixel count + TIFFTAG_CLEANFAXDATA = 327; // regenerated line info + CLEANFAXDATA_CLEAN = 0; // no errors detected + CLEANFAXDATA_REGENERATED = 1; // receiver regenerated lines + CLEANFAXDATA_UNCLEAN = 2; // uncorrected errors exist + TIFFTAG_CONSECUTIVEBADFAXLINES = 328; // max consecutive bad lines + TIFFTAG_SUBIFD = 330; // subimage descriptors + TIFFTAG_INKSET = 332; // inks in separated image + INKSET_CMYK = 1; // cyan-magenta-yellow-black + TIFFTAG_INKNAMES = 333; // ascii names of inks + TIFFTAG_DOTRANGE = 336; // 0% and 100% dot codes + TIFFTAG_TARGETPRINTER = 337; // separation target + TIFFTAG_EXTRASAMPLES = 338; // info about extra samples + EXTRASAMPLE_UNSPECIFIED = 0; // unspecified data + EXTRASAMPLE_ASSOCALPHA = 1; // associated alpha data + EXTRASAMPLE_UNASSALPHA = 2; // unassociated alpha data + TIFFTAG_SAMPLEFORMAT = 339; // data sample format + SAMPLEFORMAT_UINT = 1; // unsigned integer data + SAMPLEFORMAT_INT = 2; // signed integer data + SAMPLEFORMAT_IEEEFP = 3; // IEEE floating point data + SAMPLEFORMAT_VOID = 4; // untyped data + TIFFTAG_SMINSAMPLEVALUE = 340; // variable MinSampleValue + TIFFTAG_SMAXSAMPLEVALUE = 341; // variable MaxSampleValue + TIFFTAG_JPEGTABLES = 347; // JPEG table stream + + // Tags 512-521 are obsoleted by Technical Note #2 which specifies a revised JPEG-in-TIFF scheme. + + TIFFTAG_JPEGPROC = 512; // JPEG processing algorithm + JPEGPROC_BASELINE = 1; // baseline sequential + JPEGPROC_LOSSLESS = 14; // Huffman coded lossless + TIFFTAG_JPEGIFOFFSET = 513; // Pointer to SOI marker + TIFFTAG_JPEGIFBYTECOUNT = 514; // JFIF stream length + TIFFTAG_JPEGRESTARTINTERVAL = 515; // restart interval length + TIFFTAG_JPEGLOSSLESSPREDICTORS = 517; // lossless proc predictor + TIFFTAG_JPEGPOINTTRANSFORM = 518; // lossless point transform + TIFFTAG_JPEGQTABLES = 519; // Q matrice offsets + TIFFTAG_JPEGDCTABLES = 520; // DCT table offsets + TIFFTAG_JPEGACTABLES = 521; // AC coefficient offsets + TIFFTAG_YCBCRCOEFFICIENTS = 529; // RGB -> YCbCr transform + TIFFTAG_YCBCRSUBSAMPLING = 530; // YCbCr subsampling factors + TIFFTAG_YCBCRPOSITIONING = 531; // subsample positioning + YCBCRPOSITION_CENTERED = 1; // as in PostScript Level 2 + YCBCRPOSITION_COSITED = 2; // as in CCIR 601-1 + TIFFTAG_REFERENCEBLACKWHITE = 532; // colorimetry info + // tags 32952-32956 are private tags registered to Island Graphics + TIFFTAG_REFPTS = 32953; // image reference points + TIFFTAG_REGIONTACKPOINT = 32954; // region-xform tack point + TIFFTAG_REGIONWARPCORNERS = 32955; // warp quadrilateral + TIFFTAG_REGIONAFFINE = 32956; // affine transformation mat + // tags 32995-32999 are private tags registered to SGI + TIFFTAG_MATTEING = 32995; // use ExtraSamples + TIFFTAG_DATATYPE = 32996; // use SampleFormat + TIFFTAG_IMAGEDEPTH = 32997; // z depth of image + TIFFTAG_TILEDEPTH = 32998; // z depth/data tile + + // tags 33300-33309 are private tags registered to Pixar + // + // TIFFTAG_PIXAR_IMAGEFULLWIDTH and TIFFTAG_PIXAR_IMAGEFULLLENGTH + // are set when an image has been cropped out of a larger image. + // They reflect the size of the original uncropped image. + // The TIFFTAG_XPOSITION and TIFFTAG_YPOSITION can be used + // to determine the position of the smaller image in the larger one. + + TIFFTAG_PIXAR_IMAGEFULLWIDTH = 33300; // full image size in x + TIFFTAG_PIXAR_IMAGEFULLLENGTH = 33301; // full image size in y + // tag 33405 is a private tag registered to Eastman Kodak + TIFFTAG_WRITERSERIALNUMBER = 33405; // device serial number + // tag 33432 is listed in the 6.0 spec w/ unknown ownership + TIFFTAG_COPYRIGHT = 33432; // copyright string + // 34016-34029 are reserved for ANSI IT8 TIFF/IT YCbCr convert? + JPEGCOLORMODE_RAW = $0000; // no conversion (default) + JPEGCOLORMODE_RGB = $0001; // do auto conversion + TIFFTAG_JPEGTABLESMODE = 65539; // What to put in JPEGTables + JPEGTABLESMODE_QUANT = $0001; // include quantization tbls + JPEGTABLESMODE_HUFF = $0002; // include Huffman tbls + // Note: default is JPEGTABLESMODE_QUANT or JPEGTABLESMODE_HUFF + TIFFTAG_FAXFILLFUNC = 65540; // G3/G4 fill function + TIFFTAG_PIXARLOGDATAFMT = 65549; // PixarLogCodec I/O data sz + PIXARLOGDATAFMT_8BIT = 0; // regular u_char samples + PIXARLOGDATAFMT_8BITABGR = 1; // ABGR-order u_chars + PIXARLOGDATAFMT_11BITLOG = 2; // 11-bit log-encoded (raw) + PIXARLOGDATAFMT_12BITPICIO = 3; // as per PICIO (1.0==2048) + PIXARLOGDATAFMT_16BIT = 4; // signed short samples + PIXARLOGDATAFMT_FLOAT = 5; // IEEE float samples + // 65550-65556 are allocated to Oceana Matrix + TIFFTAG_DCSIMAGERTYPE = 65550; // imager model & filter + DCSIMAGERMODEL_M3 = 0; // M3 chip (1280 x 1024) + DCSIMAGERMODEL_M5 = 1; // M5 chip (1536 x 1024) + DCSIMAGERMODEL_M6 = 2; // M6 chip (3072 x 2048) + DCSIMAGERFILTER_IR = 0; // infrared filter + DCSIMAGERFILTER_MONO = 1; // monochrome filter + DCSIMAGERFILTER_CFA = 2; // color filter array + DCSIMAGERFILTER_OTHER = 3; // other filter + TIFFTAG_DCSINTERPMODE = 65551; // interpolation mode + DCSINTERPMODE_NORMAL = $0; // whole image, default + DCSINTERPMODE_PREVIEW = $1; // preview of image (384x256) + TIFFTAG_DCSBALANCEARRAY = 65552; // color balance values + TIFFTAG_DCSCORRECTMATRIX = 65553; // color correction values + TIFFTAG_DCSGAMMA = 65554; // gamma value + TIFFTAG_DCSTOESHOULDERPTS = 65555; // toe & shoulder points + TIFFTAG_DCSCALIBRATIONFD = 65556; // calibration file desc + // Note: quality level is on the ZLIB 1-9 scale. Default value is -1 + TIFFTAG_ZIPQUALITY = 65557; // compression quality level + TIFFTAG_PIXARLOGQUALITY = 65558; // PixarLog uses same scale + + // TIFF data types + TIFF_NOTYPE = 0; // placeholder + TIFF_BYTE = 1; // 8-bit unsigned integer + TIFF_ASCII = 2; // 8-bit bytes w/ last byte null + TIFF_SHORT = 3; // 16-bit unsigned integer + TIFF_LONG = 4; // 32-bit unsigned integer + TIFF_RATIONAL = 5; // 64-bit unsigned fraction + TIFF_SBYTE = 6; // 8-bit signed integer + TIFF_UNDEFINED = 7; // 8-bit untyped data + TIFF_SSHORT = 8; // 16-bit signed integer + TIFF_SLONG = 9; // 32-bit signed integer + TIFF_SRATIONAL = 10; // 64-bit signed fraction + TIFF_FLOAT = 11; // 32-bit IEEE floating point + TIFF_DOUBLE = 12; // 64-bit IEEE floating point + + TIFF_BIGENDIAN = $4D4D; + TIFF_LITTLEENDIAN = $4949; + + TIFF_VERSION = 42; + +type + TTIFFHeader = packed record + ByteOrder: word; + Version: word; + FirstIFD: cardinal; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TTIFFGraphic.CanLoad(Stream: PStream): boolean; +var Header: TTIFFHeader; + LastPosition: Cardinal; +begin + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + LastPosition:=Stream.Position; + Stream.Read(Header,sizeof(Header)); + Result:=(Header.ByteOrder=TIFF_BIGENDIAN) or (Header.ByteOrder=TIFF_LITTLEENDIAN); + if Result then + begin + if Header.ByteOrder=TIFF_BIGENDIAN then + begin + Header.Version:=System.Swap(Header.Version); + Header.FirstIFD:=SwapLong(Header.FirstIFD); + end; + Result:=(Header.Version=TIFF_VERSION) and (Integer(Header.FirstIFD)<(Stream.Size-Integer(LastPosition))); + end; + Stream.Position:=LastPosition; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TTIFFGraphic.FindTag(Tag: cardinal; var Index: cardinal): boolean; +// looks through the currently loaded IFD for the entry indicated by Tag; +// returns True and the index of the entry in Index if the entry is there +// otherwise the result is False and Index undefined +// Note: The IFD is sorted so we can use a binary search here. +var L,H,I,C: integer; +begin + Result:=False; + L:=0; + H:=High(FIFD); + while L<=H do + begin + I:=(L+H) shr 1; + C:=Integer(FIFD[I].Tag)-Integer(Tag); + if C<0 then L:=I+1 else + begin + H:=I-1; + if C=0 then + begin + Result:=True; + L:=I; + end; + end; + end; + Index:=L; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +const + DataTypeToSize: array[TIFF_NOTYPE..TIFF_SLONG] of byte = (0,1,1,2,4,8,1,1,2,4); + +procedure TTIFFGraphic.GetValueList(Stream: PStream; Tag: cardinal; var Values: TByteArray); +// returns the values of the IFD entry indicated by Tag +var Index,Value,Shift: cardinal; + I: Integer; +begin + if FindTag(Tag,Index) and (FIFD[Index].DataLength>0) then + begin + // prepare value list + SetLength(Values,FIFD[Index].DataLength); + // determine whether the data fits into 4 bytes + Value:=DataTypeToSize[FIFD[Index].DataType]*FIFD[Index].DataLength; + // data fits into one cardinal -> extract it + if Value<=4 then + begin + Shift:=DataTypeToSize[FIFD[Index].DataType]*8; + Value:=FIFD[Index].Offset; + for I:=0 to pred(FIFD[Index].DataLength) do + begin + case FIFD[Index].DataType of + TIFF_BYTE: + Values[I]:=Byte(Value); + TIFF_SHORT, + TIFF_SSHORT: + // no byte swap needed here because values in the IFD are already swapped + // (if necessary at all) + Values[I]:=Word(Value); + TIFF_LONG, + TIFF_SLONG: + Values[I]:=Value; + end; + Value:=Value shr Shift; + end; + end + else + begin + // data of this tag does not fit into one 32 bits value + Stream.Position:=FBasePosition+FIFD[Index].Offset; + // bytes sized data can be read directly instead of looping through the array + if FIFD[Index].DataType in [TIFF_BYTE,TIFF_ASCII,TIFF_SBYTE,TIFF_UNDEFINED] then Stream.Read(Values[0],Value) else + begin + for I:=0 to High(Values) do + begin + Stream.Read(Value,DataTypeToSize[FIFD[Index].DataType]); + case FIFD[Index].DataType of + TIFF_BYTE: + Value:=Byte(Value); + TIFF_SHORT, + TIFF_SSHORT: + begin + if ioBigEndian in FImageProperties.Options then Value:=System.Swap(Word(Value)) else Value:=Word(Value); + end; + TIFF_LONG, + TIFF_SLONG: + if ioBigEndian in FImageProperties.Options then Value:=SwapLong(Value); + end; + Values[I]:=Value; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTIFFGraphic.GetValueList(Stream: PStream; Tag: cardinal; var Values: TCardinalArray); +// returns the values of the IFD entry indicated by Tag +var Index,Value,Shift: cardinal; + I: integer; +begin +// Values:=nil; + if FindTag(Tag,Index) and (FIFD[Index].DataLength>0) then + begin + // prepare value list + SetLength(Values,FIFD[Index].DataLength); + // determine whether the data fits into 4 bytes + Value:=DataTypeToSize[FIFD[Index].DataType]*FIFD[Index].DataLength; + // data fits into one cardinal -> extract it + if Value<=4 then + begin + Shift:=DataTypeToSize[FIFD[Index].DataType]*8; + Value:=FIFD[Index].Offset; + for I:=0 to pred(FIFD[Index].DataLength) do + begin + case FIFD[Index].DataType of + TIFF_BYTE, + TIFF_ASCII, + TIFF_SBYTE, + TIFF_UNDEFINED: Values[I]:=Byte(Value); + TIFF_SHORT, + TIFF_SSHORT: + // no byte swap needed here because values in the IFD are already swapped + // (if necessary at all) + Values[I]:=Word(Value); + TIFF_LONG, + TIFF_SLONG: + Values[I]:=Value; + end; + Value:=Value shr Shift; + end; + end + else + begin + // data of this tag does not fit into one 32 bits value + Stream.Position:=FBasePosition+FIFD[Index].Offset; + // even bytes sized data must be read by the loop as it is expanded to cardinals + for I:=0 to High(Values) do + begin + Stream.Read(Value,DataTypeToSize[FIFD[Index].DataType]); + case FIFD[Index].DataType of + TIFF_BYTE: + Value:=Byte(Value); + TIFF_SHORT, + TIFF_SSHORT: + begin + if ioBigEndian in FImageProperties.Options then Value:=System.Swap(Word(Value)) else Value:=Word(Value); + end; + TIFF_LONG, + TIFF_SLONG: + if ioBigEndian in FImageProperties.Options then Value:=SwapLong(Value); + end; + Values[I]:=Value; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTIFFGraphic.GetValueList(Stream: PStream; Tag: Cardinal; var Values: TFloatArray); +// returns the values of the IFD entry indicated by Tag +var Index,Shift,IntValue: cardinal; + Value: single; + I: integer; + IntNominator,IntDenominator,FloatNominator,FloatDenominator: cardinal; +begin +// Values:=nil; + if FindTag(Tag,Index) and (FIFD[Index].DataLength>0) then + begin + // prepare value list + SetLength(Values,FIFD[Index].DataLength); + // determine whether the data fits into 4 bytes + Value:=DataTypeToSize[FIFD[Index].DataType]*FIFD[Index].DataLength; + // data fits into one cardinal -> extract it + if Value<=4 then + begin + Shift:=DataTypeToSize[FIFD[Index].DataType]*8; + IntValue:=FIFD[Index].Offset; + for I:=0 to pred(FIFD[Index].DataLength) do + begin + case FIFD[Index].DataType of + TIFF_BYTE, + TIFF_ASCII, + TIFF_SBYTE, + TIFF_UNDEFINED: + Values[I]:=Byte(IntValue); + TIFF_SHORT, + TIFF_SSHORT: + // no byte swap needed here because values in the IFD are already swapped + // (if necessary at all) + Values[I]:=Word(IntValue); + TIFF_LONG, + TIFF_SLONG: + Values[I]:=IntValue; + end; + IntValue:=IntValue shr Shift; + end; + end + else + begin + // data of this tag does not fit into one 32 bits value + Stream.Position:=FBasePosition+FIFD[Index].Offset; + // even bytes sized data must be read by the loop as it is expanded to Single + for I:=0 to High(Values) do + begin + case FIFD[Index].DataType of + TIFF_BYTE: + begin + Stream.Read(IntValue,DataTypeToSize[FIFD[Index].DataType]); + Value:=Byte(IntValue); + end; + TIFF_SHORT, + TIFF_SSHORT: + begin + Stream.Read(IntValue,DataTypeToSize[FIFD[Index].DataType]); + if ioBigEndian in FImageProperties.Options then Value:=System.Swap(Word(IntValue)) else Value:=Word(IntValue); + end; + TIFF_LONG, + TIFF_SLONG: + begin + Stream.Read(IntValue,DataTypeToSize[FIFD[Index].DataType]); + if ioBigEndian in FImageProperties.Options then Value:=SwapLong(IntValue); + end; + TIFF_RATIONAL, + TIFF_SRATIONAL: + begin + Stream.Read(FloatNominator,sizeof(FloatNominator)); + Stream.Read(FloatDenominator,sizeof(FloatDenominator)); + if ioBigEndian in FImageProperties.Options then + begin + FloatNominator:=SwapLong(Cardinal(FloatNominator)); + FloatDenominator:=SwapLong(Cardinal(FloatDenominator)); + end; + Value:=FloatNominator/FloatDenominator; + end; + TIFF_FLOAT: + begin + Stream.Read(IntNominator,sizeof(IntNominator)); + Stream.Read(IntDenominator,sizeof(IntDenominator)); + if ioBigEndian in FImageProperties.Options then + begin + IntNominator:=SwapLong(IntNominator); + IntDenominator:=SwapLong(IntDenominator); + end; + Value:=IntNominator/IntDenominator; + end; + end; + Values[I]:=Value; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TTIFFGraphic.GetValue(Stream: PStream; Tag: cardinal; Default: single = 0): single; +// returns the value of the IFD entry indicated by Tag or the default value if the entry is not there +var Index: cardinal; + IntNominator,IntDenominator: cardinal; + FloatNominator,FloatDenominator: cardinal; +begin + Result:=Default; + if FindTag(Tag,Index) then + begin + // if the data length is>1 then Offset is a real offset into the stream, + // otherwise it is the value itself and must be shortend depending on the data type + if FIFD[Index].DataLength=1 then + begin + case FIFD[Index].DataType of + TIFF_BYTE: + Result:=Byte(FIFD[Index].Offset); + TIFF_SHORT, + TIFF_SSHORT: + Result:=Word(FIFD[Index].Offset); + TIFF_LONG, + TIFF_SLONG: // nothing to do + Result:=FIFD[Index].Offset; + TIFF_RATIONAL, + TIFF_SRATIONAL: + begin + Stream.Position:=FBasePosition+FIFD[Index].Offset; + Stream.Read(FloatNominator,sizeof(FloatNominator)); + Stream.Read(FloatDenominator,sizeof(FloatDenominator)); + if ioBigEndian in FImageProperties.Options then + begin + FloatNominator:=SwapLong(Cardinal(FloatNominator)); + FloatDenominator:=SwapLong(Cardinal(FloatDenominator)); + end; + Result:=FloatNominator/FloatDenominator; + end; + TIFF_FLOAT: + begin + Stream.Position:=FBasePosition+FIFD[Index].Offset; + Stream.Read(IntNominator,sizeof(IntNominator)); + Stream.Read(IntDenominator,sizeof(IntDenominator)); + if ioBigEndian in FImageProperties.Options then + begin + IntNominator:=SwapLong(IntNominator); + IntDenominator:=SwapLong(IntDenominator); + end; + Result:=IntNominator/IntDenominator; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TTIFFGraphic.GetValue(Tag: cardinal; Default: cardinal=0): cardinal; +// returns the value of the IFD entry indicated by Tag or the default value if the entry is not there +var Index: cardinal; +begin + if not FindTag(Tag, Index) then Result:=Default else + begin + Result:=FIFD[Index].Offset; + // if the data length is>1 then Offset is a real offset into the stream, + // otherwise it is the value itself and must be shortend depending on the data type + if FIFD[Index].DataLength=1 then + begin + case FIFD[Index].DataType of + TIFF_BYTE: + Result:=Byte(Result); + TIFF_SHORT, + TIFF_SSHORT: + Result:=Word(Result); + TIFF_LONG, + TIFF_SLONG: // nothing to do + ; + else + Result:=Default; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TTIFFGraphic.GetValue(Tag: cardinal; var Size: cardinal; Default: cardinal): cardinal; +// Returns the value of the IFD entry indicated by Tag or the default value if the entry is not there. +// If the tag exists then also the data size is returned. +var Index: cardinal; +begin + if not FindTag(Tag,Index) then + begin + Result:=Default; + Size:=0; + end + else + begin + Result:=FIFD[Index].Offset; + Size:=FIFD[Index].DataLength; + // if the data length is>1 then Offset is a real offset into the stream, + // otherwise it is the value itself and must be shortend depending on the data type + if FIFD[Index].DataLength=1 then + begin + case FIFD[Index].DataType of + TIFF_BYTE: + Result:=Byte(Result); + TIFF_SHORT, + TIFF_SSHORT: + Result:=Word(Result); + TIFF_LONG, + TIFF_SLONG: // nothing to do + ; + else + Result:=Default; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTIFFGraphic.SortIFD; +// Although all entries in the IFD should be sorted there are still files where this is not the case. +// Because the lookup for certain tags in the IFD uses binary search it must be made sure the IFD is +// sorted (what we do here). + + //--------------- local function -------------------------------------------- + procedure QuickSort(L, R: Integer); + var I,J,M: integer; + T: TIFDEntry; + begin + repeat + I:=L; + J:=R; + M:=(L+R) shr 1; + repeat + while FIFD[I].TagFIFD[M].Tag do Dec(J); + if I<=J then + begin + T:=FIFD[I]; + FIFD[I]:=FIFD[J]; + FIFD[J]:=T; + Inc(I); + Dec(J); + end; + until I>J; + if L=R; + end; + //--------------- end local functions --------------------------------------- +begin + QuickSort(0,High(FIFD)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTIFFGraphic.SwapIFD; +// swap the member fields of all entries of the currently loaded IFD from big endian to little endian +var I: integer; + Size: cardinal; +begin + for I:=0 to High(FIFD) do + with FIFD[I] do + begin + Tag:=System.Swap(Tag); + DataType:=System.Swap(DataType); + DataLength:=SwapLong(DataLength); + // determine whether the data fits into 4 bytes + Size:=DataTypeToSize[FIFD[I].DataType]*FIFD[I].DataLength; + if Size>=4 then Offset:=SwapLong(Offset) else + case DataType of + TIFF_SHORT,TIFF_SSHORT: if DataLength>1 then Offset:=SwapLong(Offset) else Offset:=System.Swap(Word(Offset)); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTIFFGraphic.LoadFromStream(Stream: PStream); +var IFDCount: word; + Buffer: pointer; + Run: PChar; + Pixels,EncodedData,DataPointerCopy: pointer; + Offsets,ByteCounts: TCardinalArray; + ColorMap: cardinal; + StripSize: cardinal; + Decoder: TDecoder; + // dynamically assigned handler + Deprediction: procedure(P: pointer; Count: cardinal); +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + Deprediction:=nil; + Decoder:=nil; + // we need to keep the current stream position because all position information + // are relative to this one + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + try + // tiled images aren't supported + if ioTiled in Options then Exit; + // read data of the first image file directory (IFD) + Stream.Position:=FBasePosition+FirstIFD; + Stream.Read(IFDCount,sizeof(IFDCount)); + if ioBigEndian in Options then IFDCount:=System.Swap(IFDCount); + SetLength(FIFD,IFDCount); + Stream.Read(FIFD[0],IFDCount*sizeof(TIFDEntry)); + if ioBigEndian in Options then SwapIFD; + SortIFD; + // --- read the data of the directory which are needed to actually load the image: + // data organization + GetValueList(Stream,TIFFTAG_STRIPOFFSETS,Offsets); + GetValueList(Stream,TIFFTAG_STRIPBYTECOUNTS,ByteCounts); + // retrive additional tile data if necessary + if ioTiled in Options then + begin + GetValueList(Stream,TIFFTAG_TILEOFFSETS,Offsets); + GetValueList(Stream,TIFFTAG_TILEBYTECOUNTS,ByteCounts); + end; + // determine pixelformat and setup color conversion + if ioBigEndian in Options then ColorManager.SourceOptions:=[coNeedByteSwap] else ColorManager.SourceOptions:=[]; + ColorManager.SourceBitsPerSample:=BitsPerSample; + if ColorManager.SourceBitsPerSample=16 then ColorManager.TargetBitsPerSample:=8 else ColorManager.TargetBitsPerSample:=ColorManager.SourceBitsPerSample; + // the JPEG lib does internally a conversion to RGB + if Compression in [ctOJPEG,ctJPEG] then ColorManager.SourceColorScheme:=csBGR else ColorManager.SourceColorScheme:=ColorScheme; + case ColorManager.SourceColorScheme of + csRGBA: ColorManager.TargetColorScheme:=csBGRA; + csRGB: ColorManager.TargetColorScheme:=csBGR; + csCMY,csCMYK,csCIELab,csYCbCr: ColorManager.TargetColorScheme:=csBGR; + csIndexed: + begin + if HasAlpha then ColorManager.SourceColorScheme:=csGA; // fake indexed images with alpha (used in EPS) + // as being grayscale with alpha + ColorManager.TargetColorScheme:=csIndexed; + end; + else + ColorManager.TargetColorScheme:=ColorManager.SourceColorScheme; + end; + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + // now that the pixel format is set we can also set the (possibly large) image dimensions + FBitmap:=NewBitmap(Width,Height); + if ColorManager.SourceColorScheme=csCMYK then ColorManager.TargetSamplesPerPixel:=3 else ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + if ColorManager.SourceColorScheme=csCIELab then ColorManager.SourceOptions:=ColorManager.SourceOptions+[coLabByteRange]; + if ColorManager.SourceColorScheme=csGA then FBitmap.PixelFormat:=pf8Bit else FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + if (Width=0) or (Height=0) then GraphicExError(1{gesInvalidImage},[TIF]); + if ColorManager.TargetColorScheme in [csIndexed,csG,csGA] then + begin + // load palette data and build palette + if ColorManager.TargetColorScheme=csIndexed then + begin + ColorMap:=GetValue(TIFFTAG_COLORMAP,StripSize,0); + if StripSize>0 then + begin + Stream.Position:=FBasePosition+ColorMap; + // number of palette entries is also given by the color map tag + // (3 components each (r,g,b) and two bytes per component) + Stream.Read(FPalette[0],2*StripSize); + ColorManager.CreateColorPalette(FBitmap,[@FPalette[0],@FPalette[StripSize div 3],@FPalette[2*StripSize div 3]],pfPlane16Triple,StripSize,False); + end; + end + else ColorManager.CreateGrayScalePalette(FBitmap,ioMinIsWhite in Options); + end + else + if ColorManager.SourceColorScheme=csYCbCr then ColorManager.SetYCbCrParameters(FYCbCrCoefficients,YCbCrSubSampling[0],YCbCrSubSampling[1]); + // intermediate buffer for data + BytesPerLine:=(BitsPerPixel*Width+7) div 8; + // determine prediction scheme + if Compression<>ctNone then + begin + // Prediction without compression makes no sense at all (as it is to improve + // compression ratios). Appearently there are image which are uncompressed but still + // have a prediction scheme set. Hence we must check for it. + case Predictor of + PREDICTION_HORZ_DIFFERENCING: // currently only one prediction scheme is defined + case SamplesPerPixel of + 4: Deprediction:=Depredict4; + 3: Deprediction:=Depredict3; + else Deprediction:=Depredict1; + end; + end; + end; + // create decompressor for the image + case Compression of + ctNone: ; + ctLZW: Decoder:=TTIFFLZWDecoder.Create; + ctPackedBits: Decoder:=TPackbitsRLEDecoder.Create; + ctFaxRLE, + ctFaxRLEW: Decoder:=TCCITTMHDecoder.Create(GetValue(TIFFTAG_GROUP3OPTIONS),ioReversed in Options,Compression=ctFaxRLEW,Width); + ctFax3: Decoder:=TCCITTFax3Decoder.Create(GetValue(TIFFTAG_GROUP3OPTIONS),ioReversed in Options,False,Width); + ctThunderscan: Decoder:=TThunderDecoder.Create(Width); + ctLZ77: Decoder:=TLZ77Decoder.Create(Z_PARTIAL_FLUSH,True); + else + { + COMPRESSION_OJPEG, + COMPRESSION_CCITTFAX4 + COMPRESSION_NEXT + COMPRESSION_IT8CTPAD + COMPRESSION_IT8LW + COMPRESSION_IT8MP + COMPRESSION_IT8BL + COMPRESSION_PIXARFILM + COMPRESSION_PIXARLOG + COMPRESSION_DCS + COMPRESSION_JBIG} + GraphicExError(5{gesUnsupportedFeature},[ErrorMsg[11]{gesCompressionScheme},TIF]); + end; + if Assigned(Decoder) then Decoder.DecodeInit; + // go for each strip in the image (which might contain more than one line) + CurrentRow:=0; + CurrentStrip:=0; + StripCount:=Length(Offsets); + while CurrentStrip0) and (TileLength>0) then Include(Options,ioTiled); + // photometric interpretation determines the color space + PhotometricInterpretation:=GetValue(TIFFTAG_PHOTOMETRIC); + // type of extra information for additional samples per pixel + GetValueList(Stream,TIFFTAG_EXTRASAMPLES,ExtraSamples); + // determine whether extra samples must be considered + HasAlpha:=Length(ExtraSamples)>0; + // if any of the extra sample contains an invalid value then consider + // it as being not existant to avoid wrong interpretation for badly + // written images + if HasAlpha then + begin + for Index:=0 to High(ExtraSamples) do + if ExtraSamples[Index]>EXTRASAMPLE_UNASSALPHA then + begin + HasAlpha:=False; + Break; + end; + end; + // currently all bits per sample values are equal + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + // create decompressor for the image + TIFCompression:=GetValue(TIFFTAG_COMPRESSION); + case TIFCompression of + COMPRESSION_NONE: Compression:=ctNone; + COMPRESSION_LZW: Compression:=ctLZW; + COMPRESSION_PACKBITS: Compression:=ctPackedBits; + COMPRESSION_CCITTRLE: Compression:=ctFaxRLE; + COMPRESSION_CCITTRLEW: Compression:=ctFaxRLEW; + COMPRESSION_CCITTFAX3: Compression:=ctFax3; + COMPRESSION_OJPEG: Compression:=ctOJPEG; + COMPRESSION_JPEG: Compression:=ctJPEG; + COMPRESSION_CCITTFAX4: Compression:=ctFax4; + COMPRESSION_NEXT: Compression:=ctNext; + COMPRESSION_THUNDERSCAN: Compression:=ctThunderscan; + COMPRESSION_IT8CTPAD: Compression:=ctIT8CTPAD; + COMPRESSION_IT8LW: Compression:=ctIT8LW; + COMPRESSION_IT8MP: Compression:=ctIT8MP; + COMPRESSION_IT8BL: Compression:=ctIT8BL; + COMPRESSION_PIXARFILM: Compression:=ctPixarFilm; + COMPRESSION_PIXARLOG: Compression:=ctPixarLog; // also a LZ77 clone + COMPRESSION_ADOBE_DEFLATE, + COMPRESSION_DEFLATE: Compression:=ctLZ77; + COMPRESSION_DCS: Compression:=ctDCS; + COMPRESSION_JBIG: Compression:=ctJBIG; + else Compression:=ctUnknown; + end; + if PhotometricInterpretation in [PHOTOMETRIC_MINISWHITE..PHOTOMETRIC_CIELAB] then + begin + ColorScheme:=PhotometricToColorScheme[PhotometricInterpretation]; + if (PhotometricInterpretation=PHOTOMETRIC_RGB) and (SamplesPerPixel<4) then ColorScheme:=csRGB; + if PhotometricInterpretation=PHOTOMETRIC_MINISWHITE then Include(Options,ioMinIsWhite); + // extra work necessary for YCbCr + if PhotometricInterpretation=PHOTOMETRIC_YCBCR then + begin + if FindTag(TIFFTAG_YCBCRSUBSAMPLING,Index) then GetValueList(Stream,TIFFTAG_YCBCRSUBSAMPLING,YCbCrSubSampling) else + begin + // initialize default values if nothing is given in the file + SetLength(YCbCrSubSampling,2); + YCbCrSubSampling[0]:=2; + YCbCrSubSampling[1]:=2; + end; + if FindTag(TIFFTAG_YCBCRPOSITIONING,Index) then FYCbCrPositioning:=GetValue(TIFFTAG_YCBCRPOSITIONING) else FYCbCrPositioning:=YCBCRPOSITION_CENTERED; + if FindTag(TIFFTAG_YCBCRCOEFFICIENTS,Index) then GetValueList(Stream,TIFFTAG_YCBCRCOEFFICIENTS,FYCbCrCoefficients) else + begin + // defaults are from CCIR recommendation 601-1 + SetLength(FYCbCrCoefficients,3); + FYCbCrCoefficients[0]:=0.299; + FYCbCrCoefficients[1]:=0.587; + FYCbCrCoefficients[2]:=0.114; + end; + end; + end + else ColorScheme:=csUnknown; + JPEGColorMode:=GetValue(TIFFTAG_JPEGCOLORMODE,JPEGCOLORMODE_RAW); + JPEGTablesMode:=GetValue(TIFFTAG_JPEGTABLESMODE,JPEGTABLESMODE_QUANT or JPEGTABLESMODE_HUFF); + PlanarConfig:=GetValue(TIFFTAG_PLANARCONFIG); + // other image properties + XResolution:=GetValue(Stream,TIFFTAG_XRESOLUTION); + YResolution:=GetValue(Stream,TIFFTAG_YRESOLUTION); + if GetValue(TIFFTAG_RESOLUTIONUNIT,RESUNIT_INCH)=RESUNIT_CENTIMETER then + begin + // Resolution is given in centimeters. + // Although I personally prefer the metric system over the old english one :-) + // I still convert to inches because it is an unwritten rule to give image resolutions in dpi. + XResolution:=XResolution*2.54; + YResolution:=YResolution*2.54; + end; + // determine prediction scheme + Predictor:=GetValue(TIFFTAG_PREDICTOR); + // determine fill order in bytes + if GetValue(TIFFTAG_FILLORDER,FILLORDER_MSB2LSB)=FILLORDER_LSB2MSB then Include(Options,ioReversed); + // finally show that we found and read an image + Result:=True; + end; + end; +end; + +//----------------- TEPSGraphic ---------------------------------------------------------------------------------------- + +// Note: This EPS implementation does only read embedded pixel graphics in TIF format (preview). +// Credits to: +// Olaf Stieleke +// Torsten Pohlmeyer +// CPS Krohn GmbH +// for providing the base information about how to read the preview image. + +type + TEPSHeader = packed record + Code: cardinal; // alway $C6D3D0C5, if not there then this is not an EPS or it is not a binary EPS + PSStart, // Offset PostScript-Code + PSLen, // length of PostScript-Code + MetaPos, // position of a WMF + MetaLen, // length of a WMF + TiffPos, // position of TIFF (preview images should be either WMF or TIF but not both) + TiffLen: integer; // length of the TIFF + Checksum: smallint; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TEPSGraphic.CanLoad(Stream: PStream): boolean; +var Header: TEPSHeader; + LastPosition: cardinal; +begin + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + LastPosition:=Stream.Position; + Stream.Read(Header,sizeof(Header)); + Result:=(Header.Code=$C6D3D0C5) and (Header.TiffPos>Integer(LastPosition)+sizeof(Header)) and (Header.TiffLen>0); + Stream.Position:=LastPosition; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TEPSGraphic.LoadFromStream(Stream: PStream); +var Header: TEPSHeader; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + Stream.Read(Header,sizeof(Header)); + if Header.Code<>$C6D3D0C5 then GraphicExError(1{gesInvalidImage},['EPS']); + Stream.Seek(Header.TIFFPos-sizeof(Header),spCurrent); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEPSGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); +end; + +//----------------- TTGAGraphic -------------------------------------------------------------------------------------- + +// FILE STRUCTURE FOR THE ORIGINAL TRUEVISION TGA FILE +// FIELD 1: NUMBER OF CHARACTERS IN ID FIELD (1 BYTES) +// FIELD 2: COLOR MAP TYPE (1 BYTES) +// FIELD 3: IMAGE TYPE CODE (1 BYTES) +// = 0 NO IMAGE DATA INCLUDED +// = 1 UNCOMPRESSED, COLOR-MAPPED IMAGE +// = 2 UNCOMPRESSED, TRUE-COLOR IMAGE +// = 3 UNCOMPRESSED, BLACK AND WHITE IMAGE (black and white is actually grayscale) +// = 9 RUN-LENGTH ENCODED COLOR-MAPPED IMAGE +// = 10 RUN-LENGTH ENCODED TRUE-COLOR IMAGE +// = 11 RUN-LENGTH ENCODED BLACK AND WHITE IMAGE +// FIELD 4: COLOR MAP SPECIFICATION (5 BYTES) +// 4.1: COLOR MAP ORIGIN (2 BYTES) +// 4.2: COLOR MAP LENGTH (2 BYTES) +// 4.3: COLOR MAP ENTRY SIZE (1 BYTES) +// FIELD 5:IMAGE SPECIFICATION (10 BYTES) +// 5.1: X-ORIGIN OF IMAGE (2 BYTES) +// 5.2: Y-ORIGIN OF IMAGE (2 BYTES) +// 5.3: WIDTH OF IMAGE (2 BYTES) +// 5.4: HEIGHT OF IMAGE (2 BYTES) +// 5.5: IMAGE PIXEL SIZE (1 BYTE) +// 5.6: IMAGE DESCRIPTOR BYTE (1 BYTE) +// bit 0..3: attribute bits per pixel +// bit 4..5: image orientation: +// 0: bottom left +// 1: bottom right +// 2: top left +// 3: top right +// bit 6..7: interleaved flag +// 0: two way (even-odd) interleave (e.g. IBM Graphics Card Adapter), obsolete +// 1: four way interleave (e.g. AT&T 6300 High Resolution), obsolete +// FIELD 6: IMAGE ID FIELD (LENGTH SPECIFIED BY FIELD 1) +// FIELD 7: COLOR MAP DATA (BIT WIDTH SPECIFIED BY FIELD 4.3 AND +// NUMBER OF COLOR MAP ENTRIES SPECIFIED IN FIELD 4.2) +// FIELD 8: IMAGE DATA FIELD (WIDTH AND HEIGHT SPECIFIED IN FIELD 5.3 AND 5.4) + +const + TARGA_NO_COLORMAP = 0; + TARGA_COLORMAP = 1; + + TARGA_EMPTY_IMAGE = 0; + TARGA_INDEXED_IMAGE = 1; + TARGA_TRUECOLOR_IMAGE = 2; + TARGA_BW_IMAGE = 3; + TARGA_INDEXED_RLE_IMAGE = 9; + TARGA_TRUECOLOR_RLE_IMAGE = 10; + TARGA_BW_RLE_IMAGE = 11; + +type + TTargaHeader = packed record + IDLength, + ColorMapType, + ImageType: Byte; + ColorMapOrigin, + ColorMapSize: Word; + ColorMapEntrySize: Byte; + XOrigin, + YOrigin, + Width, + Height: Word; + PixelSize: Byte; + ImageDescriptor: Byte; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TTGAGraphic.CanLoad(Stream: PStream): boolean; +var Header: TTargaHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + // Targa images are hard to determine because there is no magic id or something like that. + // Hence all we can do is to check if all values from the header are within correct limits. + Result:=(Header.ImageType in [TARGA_EMPTY_IMAGE,TARGA_INDEXED_IMAGE,TARGA_TRUECOLOR_IMAGE,TARGA_BW_IMAGE, + TARGA_INDEXED_RLE_IMAGE,TARGA_TRUECOLOR_RLE_IMAGE,TARGA_BW_RLE_IMAGE]) and + (Header.ColorMapType in [TARGA_NO_COLORMAP,TARGA_COLORMAP]) and + (Header.ColorMapEntrySize in [15,16,24,32]) and + (Header.PixelSize in [8,15,16,24,32]); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TTGAGraphic.LoadFromStream(Stream: PStream); +var Run,RLEBuffer: PChar; + I,LineSize: Integer; + LineBuffer: Pointer; + ReadLength: Integer; + Color16: Word; + Header: TTargaHeader; + FlipV: Boolean; + Decoder: TTargaRLEDecoder; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + with FImageProperties do + begin + Stream.Position:=FBasePosition; + Stream.Read(Header,sizeof(Header)); + FlipV:=(Header.ImageDescriptor and $20)<>0; + Header.ImageDescriptor:=Header.ImageDescriptor and $F; + // skip image ID + Stream.Seek(Header.IDLength,spCurrent); + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + ColorManager.SourceColorScheme:=ColorScheme; + ColorManager.SourceOptions:=[]; + ColorManager.TargetColorScheme:=csBGR; + ColorManager.SourceBitsPerSample:=BitsPerSample; + ColorManager.TargetBitsPerSample:=BitsPerSample; + FBitmap:=NewBitmap(Header.Width,Header.Height); + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + if (Header.ColorMapType=TARGA_COLORMAP) or (Header.ImageType in [TARGA_BW_IMAGE,TARGA_BW_RLE_IMAGE]) then + begin + if Header.ImageType in [TARGA_BW_IMAGE,TARGA_BW_RLE_IMAGE] then ColorManager.CreateGrayscalePalette(FBitmap,False) else + begin + LineSize:=(Header.ColorMapEntrySize div 8)*Header.ColorMapSize; + GetMem(LineBuffer,LineSize); + try + Stream.Read(LineBuffer^,LineSize); + case Header.ColorMapEntrySize of + 32: ColorManager.CreateColorPalette(FBitmap,[LineBuffer],pfInterlaced8Quad,Header.ColorMapSize,False); + 24: ColorManager.CreateColorPalette(FBitmap,[LineBuffer],pfInterlaced8Triple,Header.ColorMapSize,False); + else + begin + // 15 and 16 bits per color map entry (handle both like 555 color format + // but make 8 bit from 5 bit per color component) + for I:=0 to pred(Header.ColorMapSize) do + begin + Stream.Read(Color16,2); + FBitmap.DIBPalEntries[I]:=Windows.RGB((Color16 and $7C00) shr 7,(Color16 and $3E0) shr 2,(Color16 and $1F) shl 3); + end; + end; + end; + finally + if Assigned(LineBuffer) then FreeMem(LineBuffer); + end; + end; + end; + LineSize:=Width*(Header.PixelSize div 8); + case Header.ImageType of + TARGA_EMPTY_IMAGE: ; // nothing to do here + TARGA_BW_IMAGE, + TARGA_INDEXED_IMAGE, + TARGA_TRUECOLOR_IMAGE: + begin + for I:=0 to pred(FBitmap.Height) do + begin + if FlipV then LineBuffer:=FBitmap.ScanLine[I] else LineBuffer:=FBitmap.ScanLine[Header.Height-(I+1)]; + Stream.Read(LineBuffer^,LineSize); + end; + end; + TARGA_BW_RLE_IMAGE, + TARGA_INDEXED_RLE_IMAGE, + TARGA_TRUECOLOR_RLE_IMAGE: + begin + RLEBuffer:=nil; + Decoder:=TTargaRLEDecoder.Create(Header.PixelSize); + try + GetMem(RLEBuffer,2*LineSize); + for I:=0 to pred(FBitmap.Height) do + begin + if FlipV then LineBuffer:=FBitmap.ScanLine[I] else LineBuffer:=FBitmap.ScanLine[Header.Height-(I+1)]; + ReadLength:=Stream.Read(RLEBuffer^,2*LineSize); + Run:=RLEBuffer; + Decoder.Decode(Pointer(Run),LineBuffer,2*LineSize,FBitmap.Width); + Stream.Position:=Stream.Position-ReadLength+(Run-RLEBuffer); + end; + finally + if Assigned(RLEBuffer) then FreeMem(RLEBuffer); + Decoder.Free; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TTGAGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TTargaHeader; +begin + inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(Header,sizeof(Header)); + Header.ImageDescriptor:=Header.ImageDescriptor and $F; + Width:=Header.Width; + Height:=Header.Height; + BitsPerSample:=8; + case Header.PixelSize of + 8: begin + if Header.ImageType in [TARGA_BW_IMAGE,TARGA_BW_RLE_IMAGE] then ColorScheme:=csG else ColorScheme:=csIndexed; + SamplesPerPixel:=1; + end; + 15, + 16: // actually, 16 bit are meant being 15 bit + begin + ColorScheme:=csRGB; + BitsPerSample:=5; + SamplesPerPixel:=3; + end; + 24: begin + ColorScheme:=csRGB; + SamplesPerPixel:=3; + end; + 32: begin + ColorScheme:=csRGBA; + SamplesPerPixel:=4; + end; + end; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + if Header.ImageType in [TARGA_BW_RLE_IMAGE,TARGA_INDEXED_RLE_IMAGE,TARGA_TRUECOLOR_RLE_IMAGE] then Compression:=ctRLE else Compression:=ctNone; + Width:=Header.Width; + Height:=Header.Height; + Result:=True; + end; +end; + +//----------------- TPCXGraphic ---------------------------------------------------------------------------------------- + +type + TPCXHeader = packed record + FileID: Byte; // $0A for PCX files, $CD for SCR files + Version: Byte; // 0: version 2.5; 2: 2.8 with palette; 3: 2.8 w/o palette; 5: version 3 + Encoding: Byte; // 0: uncompressed; 1: RLE encoded + BitsPerPixel: Byte; + XMin, + YMin, + XMax, + YMax, // coordinates of the corners of the image + HRes, // horizontal resolution in dpi + VRes: Word; // vertical resolution in dpi + ColorMap: array[0..15] of TRGB; // color table + Reserved, + ColorPlanes: Byte; // color planes (at most 4) + BytesPerLine, // number of bytes of one line of one plane + PaletteType: Word; // 1: color or b&w; 2: gray scale + Fill: array[0..57] of Byte; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TPCXGraphic.CanLoad(Stream: PStream): boolean; +var Header: TPCXHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + Result:=(Header.FileID in [$0A,$0C]) and (Header.Version in [0,2,3,5]) and (Header.Encoding in [0,1]); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPCXGraphic.LoadFromStream(Stream: PStream); +var Header: TPCXHeader; + + //--------------- local functions ------------------------------------------- + procedure MakePalette; + const + Pal16: array[0..15] of TColor = + (clBlack,clMaroon,clGreen,clOlive,clNavy,clPurple,clTeal,clDkGray, + clLtGray,clRed,clLime,clYellow,clBlue,clFuchsia,clAqua,clWhite); + var PCXPalette: array[0..255] of TRGB; + I,OldPos: integer; + Marker: byte; + begin + if (Header.Version<>3) or (FBitmap.PixelFormat=pf1Bit) then + begin + case FBitmap.PixelFormat of + pf1Bit: ColorManager.CreateGrayScalePalette(FBitmap,False); + pf4Bit: + with Header do + begin + if PaletteType=2 then ColorManager.CreateGrayScalePalette(FBitmap,False) else ColorManager.CreateColorPalette(FBitmap,[@ColorMap],pfInterlaced8Triple,16,False); + end; + pf8Bit: + begin + OldPos:=Stream.Position; + // 256 colors with 3 components plus one marker byte + Stream.Position:=Stream.Size-769; + Stream.Read(Marker,1); + if Marker<>$0C then + begin + // palette ID is wrong, perhaps gray scale? + if Header.PaletteType=2 then ColorManager.CreateGrayScalePalette(FBitmap,False) else ; // ignore palette + end + else + begin + Stream.Read(PCXPalette[0],768); + ColorManager.CreateColorPalette(FBitmap,[@PCXPalette],pfInterlaced8Triple,256,True); + end; + Stream.Position:=OldPos; + end; + end; + end + else + begin + // version 2.8 without palette information, just use the system palette + // 256 colors will not be correct with this assignment... + for I:=0 to 15 do FBitmap.DIBPalEntries[I]:=Pal16[I]; + end; + end; + //--------------- end local functions --------------------------------------- + +var PCXSize,Size: cardinal; + RawBuffer,DecodeBuffer: pointer; + Run,Plane1,Plane2,Plane3,Plane4: PByte; + Value,Mask: byte; + I,J: integer; + Line: PByte; + Increment: cardinal; + NewPixelFormat: TPixelFormat; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + Stream.Position:=FBasePosition; + Stream.Read(Header,sizeof(Header)); + PCXSize:=Stream.Size-Stream.Position; + with Header,FImageProperties do + begin + if not (FileID in [$0A,$CD]) then GraphicExError(1{gesInvalidImage},['PCX or SCR']); + ColorManager.SourceColorScheme:=ColorScheme; + ColorManager.SourceBitsPerSample:=BitsPerSample; + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + if ColorScheme=csIndexed then ColorManager.TargetColorScheme:=csIndexed else ColorManager.TargetColorScheme:=csBGR; + if BitsPerPixel=2 then ColorManager.TargetBitsPerSample:=4 else ColorManager.TargetBitsPerSample:=BitsPerSample; + // Note: pixel depths of 2 and 4 bits may not be used with more than one plane + // otherwise the image will not show up correctly + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + NewPixelFormat:=ColorManager.TargetPixelFormat; + if NewPixelFormat=pfCustom then + begin + // there can be a special case comprising 4 planes each with 1 bit + if (SamplesPerPixel=4) and (BitsPerPixel=4) then NewPixelFormat:=pf4Bit else GraphicExError(2{gesInvalidColorFormat},['PCX']); + end; + FBitmap:=NewBitmap(Width,Height); + FBitmap.PixelFormat:=NewPixelFormat; + // 256 colors palette is appended to the actual PCX data + if FBitmap.PixelFormat=pf8Bit then Dec(PCXSize,769); + if FBitmap.PixelFormat<>pf24Bit then MakePalette; + // adjust alignment of line + Increment:=SamplesPerPixel*Header.BytesPerLine; + // allocate pixel data buffer and decode data if necessary + if Compression=ctRLE then + begin + Size:=Increment*Height; + GetMem(DecodeBuffer,Size); + GetMem(RawBuffer,PCXSize); + try + Stream.Read(RawBuffer^,PCXSize); + with TPCXRLEDecoder.Create do + try + Decode(RawBuffer,DecodeBuffer,PCXSize,Size); + finally + Free; + end; + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end + else + begin + GetMem(DecodeBuffer,PCXSize); + Stream.Read(DecodeBuffer^,PCXSize); + end; + try + Run:=DecodeBuffer; + if (SamplesPerPixel=4) and (BitsPerPixel=4) then + begin + // 4 planes with one bit + for I:=0 to pred(Height) do + begin + Plane1:=Run; + PChar(Plane2):=PChar(Run)+Increment div 4; + PChar(Plane3):=PChar(Run)+2*(Increment div 4); + PChar(Plane4):=PChar(Run)+3*(Increment div 4); + Line:=FBitmap.ScanLine[I]; + // number of bytes to write + Size:=(FBitmap.Width*BitsPerPixel+7) div 8; + Mask:=0; + while Size>0 do + begin + Value:=0; + for J:=0 to 1 do + asm + MOV AL,[Value] + MOV EDX,[Plane4] // take the 4 MSBs from the 4 runs and build a nibble + SHL BYTE PTR [EDX],1 // read MSB and prepare next run at the same time + RCL AL,1 // MSB from previous shift is in CF -> move it to AL + MOV EDX,[Plane3] // now do the same with the other three runs + SHL BYTE PTR [EDX],1 + RCL AL,1 + MOV EDX,[Plane2] + SHL BYTE PTR [EDX],1 + RCL AL,1 + MOV EDX,[Plane1] + SHL BYTE PTR [EDX],1 + RCL AL,1 + MOV [Value],AL + end; + Line^:=Value; + Inc(Line); + Dec(Size); + // two runs above (to construct two nibbles -> one byte), now update marker + // to know when to switch to next byte in the planes + Mask:=(Mask+2) mod 8; + if Mask=0 then + begin + Inc(Plane1); + Inc(Plane2); + Inc(Plane3); + Inc(Plane4); + end; + end; + Inc(Run,Increment); + end; + end + else + if FBitmap.PixelFormat=pf24Bit then + begin + // true color + for I:=0 to pred(FBitmap.Height) do + begin + Line:=FBitmap.ScanLine[I]; + Plane1:=Run; + PChar(Plane2):=PChar(Run)+Increment div 3; + PChar(Plane3):=PChar(Run)+2*(Increment div 3); + ColorManager.ConvertRow([Plane1,Plane2,Plane3],Line,FBitmap.Width,$FF); + Inc(Run,Increment); + end + end + else + begin + // other indexed formats + for I:=0 to pred(FBitmap.Height) do + begin + Line:=FBitmap.ScanLine[I]; + ColorManager.ConvertRow([Run],Line,FBitmap.Width,$FF); + Inc(Run,Increment); + end; + end; + finally + if Assigned(DecodeBuffer) then FreeMem(DecodeBuffer); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPCXGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TPCXHeader; +begin + Result:=inherited ReadImageProperties(Stream,0); + Stream.Read(Header,sizeof(Header)); + with FImageProperties do + begin + if Header.FileID in [$0A,$CD] then + begin + Width:=Header.XMax-Header.XMin+1; + Height:=Header.YMax-Header.YMin+1; + SamplesPerPixel:=Header.ColorPlanes; + BitsPerSample:=Header.BitsPerPixel; + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + if BitsPerPixel<=8 then ColorScheme:=csIndexed else ColorScheme:=csRGB; + if Header.Encoding=1 then Compression:=ctRLE else Compression:=ctNone; + XResolution:=Header.HRes; + YResolution:=Header.VRes; + Result:=True; + end; + end; +end; + +//----------------- TPCDGraphic ---------------------------------------------------------------------------------------- + +const + PCD_BEGIN_BASE16 = 8192; + PCD_BEGIN_BASE4 = 47104; + PCD_BEGIN_BASE = 196608; + PCD_BEGIN_ORIENTATION = 194635; + PCD_BEGIN = 2048; + + PCD_MAGIC = 'PCD_IPI'; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TPCDGraphic.CanLoad(Stream: PStream): boolean; +var Header: array[0..$802] of byte; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>3*$800; + if Result then + begin + Stream.Read(Header,Length(Header)); + Result:=(StrLComp(@Header[0],'PCD_OPA',7)=0) or (StrLComp(@Header[$800],'PCD',3)=0); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPCDGraphic.LoadFromStream(Stream: PStream); +var C1,C2,YY: PChar; + YCbCrData: array[0..2] of PChar; + SourceDummy,DestDummy: pointer; + Offset,I,X,IX,Y,IY,ImageIndex,Rows,Columns: cardinal; + ScanLines: array of pointer; + LineBuffer: pointer; + Line,Run: PBGR; + Decoder: TPCDDecoder; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + ImageIndex:=2; // third image is Base resolution + if ReadImageProperties(Stream,ImageIndex) then + begin + with FImageProperties do + begin + ScanLines:=nil; + LineBuffer:=nil; + Stream.Position:=FBasePosition; + Columns:=192 shl KOL.Min(ImageIndex,2); + Rows:=128 shl KOL.Min(ImageIndex,2); + Width:=192 shl ImageIndex; + Height:=128 shl ImageIndex; + // For the rotated mode where we need to turn the image by 90°. We can speed up loading + // the image by factor 2 by using a local copy of the Scanline pointers. + if Rotate in [1,3] then + begin + IX:=Height; + IY:=Width; + end + else + begin + IX:=Width; + IY:=Height; + end; + // since row and columns might be swapped because of rotated images + // we determine the final dimensions once more + FBitmap:=NewBitmap(IX,IY); + if Rotate in [1,3] then + begin + SetLength(ScanLines,IX); + for Y:=0 to pred(IY) do ScanLines[Y]:=FBitmap.ScanLine[Y]; + GetMem(LineBuffer,3*IY); + end; + ZeroMemory(@YCbCrData,sizeof(YCbCrData)); + try + GetMem(YCbCrData[0],FBitmap.Width*FBitmap.Height); + GetMem(YCbCrData[1],FBitmap.Width*FBitmap.Height); + GetMem(YCbCrData[2],FBitmap.Width*FBitmap.Height); + // advance to image data + Offset:=96; + if Overview then Offset:=5 else + if ImageIndex=1 then Offset:=23 else + if ImageIndex=0 then Offset:=4; + Stream.Seek(Offset*$800,spCurrent); + // color conversion setup + ColorManager.SourceColorScheme:=csPhotoYCC; + ColorManager.SourceBitsPerSample:=8; + ColorManager.SourceSamplesPerPixel:=3; + ColorManager.TargetColorScheme:=csBGR; + ColorManager.TargetBitsPerSample:=8; + ColorManager.TargetSamplesPerPixel:=3; + FBitmap.PixelFormat:=pf24Bit; + // PhotoYCC format uses CCIR Recommendation 709 coefficients and is subsampled + // by factor 2 vertically and horizontally + ColorManager.SetYCbCrParameters([0.2125,0.7154,0.0721],2,2); + if False then + begin + // if Overview then ... no info yet about overview image structure + end + else + begin + YY:=YCbCrData[0]; + C1:=YCbCrData[1]; + C2:=YCbCrData[2]; + I:=0; + while I=3 then + begin +// Inc(Y,3*(ImageIndex-3)); + Decoder:=TPCDDecoder.Create(Stream); + SourceDummy:=@YCbCrData; + DestDummy:=nil; + try + // recover luminance deltas for 1536 x 1024 image + Upsample(768,512,Width,YCbCrData[0]); + Upsample(384,256,Width,YCbCrData[1]); + Upsample(384,256,Width,YCbCrData[2]); + Stream.Seek(4*$800,spCurrent); + Decoder.Decode(SourceDummy,DestDummy,Width,1024); + if ImageIndex>=4 then + begin + // recover luminance deltas for 3072 x 2048 image + Upsample(1536,1024,FBitmap.Width,YCbCrData[0]); + Upsample(768,512,FBitmap.Width,YCbCrData[1]); + Upsample(768,512,FBitmap.Width,YCbCrData[2]); + Offset:=(Stream.Position-Integer(FBasePosition)) div $800+12; + Stream.Seek(FBasePosition+Offset*$800,spBegin); + Decoder.Decode(SourceDummy,DestDummy,Width,2048); + if ImageIndex=5 then + begin + // recover luminance deltas for 6144 x 4096 image (vaporware) + Upsample(3072,2048,FBitmap.Width,YCbCrData[1]); + Upsample(1536,1024,FBitmap.Width,YCbCrData[1]); + Upsample(1536,1024,FBitmap.Width,YCbCrData[2]); + end; + end; + finally + Decoder.Free; + end; + end; + Upsample(FBitmap.Width shr 1,FBitmap.Height shr 1,FBitmap.Width,YCbCrData[1]); + Upsample(FBitmap.Width shr 1,FBitmap.Height shr 1,FBitmap.Width,YCbCrData[2]); + // transfer luminance and chrominance channels + YY:=YCbCrData[0]; + C1:=YCbCrData[1]; + C2:=YCbCrData[2]; + try + case Rotate of + 1: // rotate -90° + begin + for Y:=0 to pred(FBitmap.Height) do + begin + ColorManager.ConvertRow([YY,C1,C2],LineBuffer,FBitmap.Width,$FF); + Inc(YY,FBitmap.Width); + Inc(C1,FBitmap.Width); + Inc(C2,FBitmap.Width); + Run:=LineBuffer; + for X:=0 to pred(FBitmap.Width) do + begin + PChar(Line):=PChar(ScanLines[FBitmap.Width-X-1])+Y*3; + Line^:=Run^; + Inc(Run); + end; + end; + end; + 3: // rotate 90° + begin + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([YY,C1,C2],LineBuffer,FBitmap.Width,$FF); + Inc(YY,FBitmap.Width); + Inc(C1,FBitmap.Width); + Inc(C2,FBitmap.Width); + Run:=LineBuffer; + for X:=0 to pred(FBitmap.Width) do + begin + PChar(Line):=PChar(ScanLines[X])+(FBitmap.Height-Y-1)*3; + Line^:=Run^; + Inc(Run); + end; + end; + end; + else + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([YY,C1,C2],FBitmap.ScanLine[Y],FBitmap.Width,$FF); + Inc(YY,FBitmap.Width); + Inc(C1,FBitmap.Width); + Inc(C2,FBitmap.Width); + end; + end; + finally + ScanLines:=nil; + if Assigned(LineBuffer) then FreeMem(LineBuffer); + end; + end; + finally + if Assigned(YCbCrData[2]) then FreeMem(YCbCrData[2]); + if Assigned(YCbCrData[1]) then FreeMem(YCbCrData[1]); + if Assigned(YCbCrData[0]) then FreeMem(YCbCrData[0]); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPCDGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: array[0..$17FF] of byte; + Temp: cardinal; +begin + if ImageIndex>5 then ImageIndex:=5; + Result:=inherited ReadImageProperties(Stream,ImageIndex) and ((Stream.Size-Integer(FBasePosition))>3*$800); + with FImageProperties do + begin + Stream.Read(Header,Length(Header)); + try + Overview:=StrLComp(@Header[0],'PCD_OPA',7)=0; + // determine if image is a PhotoCD image + if Overview or (StrLComp(@Header[$800],'PCD',3)=0) then + begin + Rotate:=Header[$0E02] and 3; + // image sizes are fixed, depending on the given image index + if Overview then ImageIndex:=0; + Width:=192 shl ImageIndex; + Height:=128 shl ImageIndex; + if (Rotate=1) or (Rotate=3) then + begin + Temp:=Width; + Width:=Height; + Height:=Temp; + end; + ColorScheme:=csPhotoYCC; + BitsPerSample:=8; + SamplesPerPixel:=3; + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + if ImageIndex>2 then Compression:=ctPCDHuffmann else Compression:=ctNone; + ImageCount:=(Header[10] shl 8) or Header[11]; + Result:=True; + end; + finally + end; + end; +end; + +//----------------- TPPMGraphic ---------------------------------------------------------------------------------------- + +class function TPPMGraphic.CanLoad(Stream: PStream): boolean; +var Buffer: array[0..9] of Char; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>10; + if Result then + begin + Stream.Read(Buffer,sizeof(Buffer)); + Result:=(Buffer[0]='P') and (Buffer[1] in ['1'..'6']); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPPMGraphic.CurrentChar: Char; +begin + if FIndex=sizeof(FBuffer) then Result:=#0 else Result:=FBuffer[FIndex]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPPMGraphic.GetChar: Char; +// buffered I/O +begin + if FIndex=sizeof(FBuffer) then + begin + if FStream.Position=FStream.Size then GraphicExError(3{gesStreamReadError},['PPM']); + FIndex:=0; + FStream.Read(FBuffer,sizeof(FBuffer)); + end; + Result:=FBuffer[FIndex]; + Inc(FIndex); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPPMGraphic.GetNumber: Cardinal; +// reads the next number from the stream (and skips all characters which are not in 0..9) +var Ch: Char; +begin + // skip all non-numbers + repeat + Ch:=GetChar; + // skip comments + if Ch='#' then + begin + ReadLine; + Ch:=GetChar; + end; + until Ch in ['0'..'9']; + // read the number characters and convert meanwhile + Result:=0; + repeat + Result:=10*Result+Ord(Ch)-$30; + Ch:=GetChar; + until not (Ch in ['0'..'9']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPPMGraphic.ReadLine: string; +// reads one text line from stream and skips comments +var Ch: Char; + I: integer; +begin + Result:=''; + repeat + Ch:=GetChar; + if Ch in [#13,#10] then Break else Result:=Result+Ch; + until False; + // eat #13#10 combination + if (Ch=#13) and (CurrentChar=#10) then GetChar; + // delete comments + I:=Pos('#',Result); + if I>0 then Delete(Result,I,MaxInt); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPPMGraphic.LoadFromStream(Stream: PStream); +var Buffer: string; + Line24: PBGR; + Line8: PByte; + X,Y,W,H: integer; + Pixel: byte; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + // copy reference for buffered access + FStream:=Stream; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + Stream.Position:=FBasePosition; + // set index pointer to end of buffer to cause reload + FIndex:=sizeof(FBuffer); + Buffer:=ReadLine; + case Str2Int(Buffer[2]) of + 1: // PBM ASCII format (black & white) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf1Bit; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.TargetBitsPerSample:=1; + ColorManager.CreateGrayScalePalette(FBitmap,True); + // read image data + for Y:=0 to pred(FBitmap.Height) do + begin + Line8:=FBitmap.ScanLine[Y]; + Pixel:=0; + for X:=1 to FBitmap.Width do + begin + Pixel:=(Pixel shl 1) or (GetNumber and 1); + if (X mod 8)=0 then + begin + Line8^:=Pixel; + Inc(Line8); + Pixel:=0; + end; + end; + if (FBitmap.Width mod 8)<>0 then Line8^:=Pixel shl (8-(FBitmap.Width mod 8)); + end; + end; + 2: // PGM ASCII form (gray scale) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf8Bit; + // skip maximum color value + GetNumber; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.TargetBitsPerSample:=8; + ColorManager.CreateGrayScalePalette(FBitmap,False); + // read image data + for Y:=0 to pred(FBitmap.Height) do + begin + Line8:=FBitmap.ScanLine[Y]; + for X:=0 to pred(FBitmap.Width) do + begin + Line8^:=GetNumber; + Inc(Line8); + end; + end; + end; + 3: // PPM ASCII form (true color) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf24Bit; + // skip maximum color value + GetNumber; + for Y:=0 to pred(FBitmap.Height) do + begin + Line24:=FBitmap.ScanLine[Y]; + for X:=0 to pred(FBitmap.Width) do + begin + Line24.R:=GetNumber; + Line24.G:=GetNumber; + Line24.B:=GetNumber; + Inc(Line24); + end; + end; + end; + 4: // PBM binary format (black & white) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf1Bit; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.TargetBitsPerSample:=1; + ColorManager.CreateGrayScalePalette(FBitmap,True); + // read image data + for Y:=0 to pred(FBitmap.Height) do + begin + Line8:=FBitmap.ScanLine[Y]; + for X:=0 to pred(FBitmap.Width div 8) do + begin + Line8^:=Byte(GetChar); + Inc(Line8); + end; + if (FBitmap.Width mod 8)<>0 then Line8^:=Byte(GetChar); + end; + end; + 5: // PGM binary form (gray scale) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf8Bit; + // skip maximum color value + GetNumber; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.TargetBitsPerSample:=8; + ColorManager.CreateGrayScalePalette(FBitmap,False); + // read image data + for Y:=0 to pred(FBitmap.Height) do + begin + Line8:=FBitmap.ScanLine[Y]; + for X:=0 to pred(FBitmap.Width) do + begin + Line8^:=Byte(GetChar); + Inc(Line8); + end; + end; + end; + 6: // PPM binary form (true color) + begin + W:=GetNumber; + H:=GetNumber; + FBitmap:=NewBitmap(W,H); + FBitmap.PixelFormat:=pf24Bit; + // skip maximum color value + GetNumber; + // Pixel values are store linearly (but RGB instead BGR). + // There's one allowed white space which will automatically be skipped by the first + // GetChar call below + // now read the pixels + for Y:=0 to pred(FBitmap.Height) do + begin + Line24:=FBitmap.ScanLine[Y]; + for X:=0 to pred(FBitmap.Width) do + begin + Line24.R:=Byte(GetChar); + Line24.G:=Byte(GetChar); + Line24.B:=Byte(GetChar); + Inc(Line24); + end; + end; + end; + end; + end; + end + else GraphicExError(1{gesInvalidImage},['PBM, PGM or PPM']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPPMGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Buffer: string; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + // set index pointer to end of buffer to cause reload + FIndex:=sizeof(FBuffer); + Buffer:=ReadLine; + Compression:=ctNone; + if Buffer[1]='P' then + begin + case Str2Int(Buffer[2]) of + 1: // PBM ASCII format (black & white) + begin + Width:=GetNumber; + Height:=GetNumber; + SamplesPerPixel:=1; + BitsPerSample:=1; + ColorScheme:=csIndexed; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + 2: // PGM ASCII form (gray scale) + begin + Width:=GetNumber; + Height:=GetNumber; + // skip maximum color value + GetNumber; + SamplesPerPixel:=1; + BitsPerSample:=8; + ColorScheme:=csIndexed; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + 3: // PPM ASCII form (true color) + begin + Width:=GetNumber; + Height:=GetNumber; + // skip maximum color value + GetNumber; + SamplesPerPixel:=3; + BitsPerSample:=8; + ColorScheme:=csRGB; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + 4: // PBM binary format (black & white) + begin + Width:=GetNumber; + Height:=GetNumber; + SamplesPerPixel:=1; + BitsPerSample:=1; + ColorScheme:=csIndexed; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + 5: // PGM binary form (gray scale) + begin + Width:=GetNumber; + Height:=GetNumber; + // skip maximum color value + GetNumber; + SamplesPerPixel:=1; + BitsPerSample:=8; + ColorScheme:=csIndexed; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + 6: // PPM binary form (true color) + begin + Width:=GetNumber; + Height:=GetNumber; + // skip maximum color value + GetNumber; + SamplesPerPixel:=3; + BitsPerSample:=8; + ColorScheme:=csRGB; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + end; + end; + Result:=True; + end; + end; +end; + +//----------------- TCUTGraphic ---------------------------------------------------------------------------------------- + +class function TCUTGraphic.CanLoad(Stream: PStream): boolean; +// Note: cut files cannot be determined from stream because the only information +// is width and height of the image at stream/image start which is by no means +// enough to identify a cut (or any other) image. +begin + Result:=False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCUTGraphic.LoadFromStream(Stream: PStream); +var Buffer: PByte; + Run,Line: pointer; + Decoder: TCUTRLEDecoder; + CUTSize: cardinal; + Y: integer; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + Stream.Position:=FBasePosition+6; + FBitmap:=NewBitmap(Width,Height); + FBitmap.PixelFormat:=pf8Bit; + LoadPalette; + CutSize:=Stream.Size-Stream.Position; + Decoder:=TCUTRLEDecoder.Create; + Buffer:=nil; + try + GetMem(Buffer,CutSize); + Stream.Read(Buffer^,CUTSize); + Run:=Buffer; + for Y:=0 to pred(FBitmap.Height) do + begin + Line:=FBitmap.ScanLine[Y]; + Decoder.Decode(Run,Line,0,FBitmap.Width); + end; + finally + Decoder.Free; + if Assigned(Buffer) then FreeMem(Buffer); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCUTGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Dummy: word; +begin + inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(Dummy,sizeof(Dummy)); + Width:=Dummy; + Stream.Read(Dummy,sizeof(Dummy)); + Height:=Dummy; + ColorScheme:=csIndexed; + BitsPerSample:=8; + SamplesPerPixel:=1; + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + Compression:=ctRLE; + Result:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + // the palette file header is actually more complex than the + // image file's header, funny... + PHaloPaletteHeader = ^THaloPaletteHeader; + THaloPaletteHeader = packed record + ID: array[0..1] of Char; // should be 'AH' + Version,Size: word; + FileType,SubType: byte; + BrdID,GrMode: word; + MaxIndex,MaxRed,MaxGreen,MaxBlue: word; // colors = MaxIndex + 1 + Signature: array[0..7] of Char; // 'Dr. Halo' + Filler: array[0..11] of byte; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCUTGraphic.LoadPalette; +var Header: PHaloPaletteHeader; + I: integer; + Buffer: array[0..511] of byte; + Run: PWord; + R,G,B: byte; + Temp: PStream; +begin + if FileExists(FPaletteFile) then + begin + Temp:=NewReadFileStream(FPaletteFile); + try + // quite strange file organization here, we need always to load 512 bytes blocks + // and skip occasionally some bytes + Temp.Read(Buffer,sizeof(Buffer)); + Header:=@Buffer; + Run:=@Buffer; + Inc(PByte(Run),sizeof(Header^)); + for I:=0 to Header.MaxIndex do + begin + // load next 512 bytes buffer if necessary + if (Integer(Run)-Integer(@Buffer))>506 then + begin + Temp.Read(Buffer,sizeof(Buffer)); + Run:=@Buffer; + end; + B:=Run^; + Inc(Run); + G:=Run^; + Inc(Run); + R:=Run^; + Inc(Run); + FBitmap.DIBPalEntries[I]:=Windows.RGB(R,G,B); + end; + finally + Temp.Free; + end; + end + else + begin + // no external palette so use gray scale + for I:=0 to 255 do FBitmap.DIBPalEntries[I]:=Windows.RGB(I,I,I); + end; +end; + +//----------------- TGIFGraphic ---------------------------------------------------------------------------------------- + +const + // logical screen descriptor packed field masks + GIF_GLOBALCOLORTABLE = $80; + GIF_COLORRESOLUTION = $70; + GIF_GLOBALCOLORTABLESORTED = $08; + GIF_COLORTABLESIZE = $07; + + // image flags + GIF_LOCALCOLORTABLE = $80; + GIF_INTERLACED = $40; + GIF_LOCALCOLORTABLESORTED= $20; + + // block identifiers + GIF_PLAINTEXT = $01; + GIF_GRAPHICCONTROLEXTENSION = $F9; + GIF_COMMENTEXTENSION = $FE; + GIF_APPLICATIONEXTENSION = $FF; + GIF_IMAGEDESCRIPTOR = Ord(','); + GIF_EXTENSIONINTRODUCER = Ord('!'); + GIF_TRAILER = Ord(';'); + +type + TGIFHeader = packed record + Signature: array[0..2] of Char; // magic ID 'GIF' + Version: array[0..2] of Char; // '87a' or '89a' + end; + + TLogicalScreenDescriptor = packed record + ScreenWidth: Word; + ScreenHeight: Word; + PackedFields, + BackgroundColorIndex, // index into global color table + AspectRatio: Byte; // actual ratio = (AspectRatio + 15) / 64 + end; + + TImageDescriptor = packed record + //Separator: Byte; // leave that out since we always read one bye ahead + Left: Word; // X position of image with respect to logical screen + Top: Word; // Y position + Width: Word; + Height: Word; + PackedFields: Byte; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TGIFGraphic.CanLoad(Stream: PStream): boolean; +var Header: TGIFHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>(sizeof(TGIFHeader)+sizeof(TLogicalScreenDescriptor)+sizeof(TImageDescriptor)); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + Result:=UpperCase(Header.Signature)='GIF'; + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TGIFGraphic.SkipExtensions: byte; +// Skips all blocks until an image block has been found in the data stream. +// Result is the image block ID if an image block could be found. +var Increment: byte; +begin + // iterate through the blocks until first image is found + repeat + FStream.Read(Result,1); + if Result=GIF_EXTENSIONINTRODUCER then + begin + // skip any extension + FStream.Read(Result,1); + case Result of + GIF_PLAINTEXT: + begin + // block size of text grid data + FStream.Read(Increment,1); + FStream.Seek(Increment,spCurrent); + // skip variable lengthed text block + repeat + // block size + FStream.Read(Increment,1); + if Increment=0 then Break; + FStream.Seek(Increment,spCurrent); + until False; + end; + GIF_GRAPHICCONTROLEXTENSION: + begin + // block size + FStream.Read(Increment,1); + // skip block and its terminator + FStream.Seek(Increment+1,spCurrent); + end; + GIF_COMMENTEXTENSION: + repeat + // block size + FStream.Read(Increment,1); + if Increment=0 then Break; + FStream.Seek(Increment,spCurrent); + until False; + GIF_APPLICATIONEXTENSION: + begin + // application id and authentication code plus potential application data + repeat + FStream.Read(Increment,1); + if Increment=0 then Break; + FStream.Seek(Increment,spCurrent); + until False; + end; + end; + end; + until (Result=GIF_IMAGEDESCRIPTOR) or (Result=GIF_TRAILER); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TGIFGraphic.LoadFromStream(Stream: PStream); +var Header: TGIFHeader; + ScreenDescriptor: TLogicalScreenDescriptor; + ImageDescriptor: TImageDescriptor; + I,NE: cardinal; + R,G,B,BlockID,InitCodeSize: byte; + RawData,Run: PByte; + TargetBuffer,TargetRun,Line: pointer; + Pass,Increment,Marker: integer; + Decoder: TDecoder; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + FStream:=Stream; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + Stream.Position:=FBasePosition; + Stream.Read(Header,sizeof(Header)); + FBitmap:=NewBitmap(Width,Height); + FBitmap.PixelFormat:=pf8Bit; + // general information + Stream.Read(ScreenDescriptor,sizeof(ScreenDescriptor)); + // read global color table if given + if (ScreenDescriptor.PackedFields and GIF_GLOBALCOLORTABLE)<>0 then + begin + // the global color table immediately follows the screen descriptor + NE:=2 shl (ScreenDescriptor.PackedFields and GIF_COLORTABLESIZE); + for I:=0 to pred(NE) do + begin + Stream.Read(B,1); + Stream.Read(G,1); + Stream.Read(R,1); + FBitmap.DIBPalEntries[I]:=Windows.RGB(R,G,B); + end; + end; + BlockID:=SkipExtensions; + // image found? + if BlockID=GIF_IMAGEDESCRIPTOR then + begin + Stream.Read(ImageDescriptor,sizeof(TImageDescriptor)); + // if there is a local color table then override the already set one + if (ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE)<>0 then + begin + // the global color table immediately follows the image descriptor + NE:=2 shl (ImageDescriptor.PackedFields and GIF_COLORTABLESIZE); + for I:=0 to pred(NE) do + begin + Stream.Read(B,1); + Stream.Read(G,1); + Stream.Read(R,1); + FBitmap.DIBPalEntries[I]:=Windows.RGB(R,G,B); + end; + end; + Stream.Read(InitCodeSize,1); + // decompress data in one step + // 1) count data + Marker:=Stream.Position; + Pass:=0; + Increment:=0; + repeat + if Stream.Read(Increment,1)=0 then Break; + Inc(Pass,Increment); + Stream.Seek(Increment,spCurrent); + until Increment=0; + // 2) allocate enough memory + GetMem(RawData,Pass); + // add one extra line of extra memory for badly coded images + GetMem(TargetBuffer,FBitmap.Width*(FBitmap.Height+1)); + try + // 3) read and decode data + Stream.Position:=Marker; + Increment:=0; + Run:=RawData; + repeat + if Stream.Read(Increment,1)=0 then Break; + Stream.Read(Run^,Increment); + Inc(Run,Increment); + until Increment=0; + Decoder:=TGIFLZWDecoder.Create(InitCodeSize); + try + Run:=RawData; + Decoder.Decode(Pointer(Run),TargetBuffer,Pass,FBitmap.Width*FBitmap.Height); + finally + Decoder.Free; + end; + // finally transfer image data + if (ImageDescriptor.PackedFields and GIF_INTERLACED)=0 then + begin + TargetRun:=TargetBuffer; + for I:=0 to pred(FBitmap.Height) do + begin + Line:=FBitmap.ScanLine[I]; + Move(TargetRun^,Line^,FBitmap.Width); + Inc(PByte(TargetRun),FBitmap.Width); + end; + end + else + begin + TargetRun:=TargetBuffer; + // interlaced image, need to move in four passes + for Pass:=0 to 3 do + begin + // determine start line and increment of the pass + case Pass of + 0: begin + I:=0; + Increment:=8; + end; + 1: begin + I:=4; + Increment:=8; + end; + 2: begin + I:=2; + Increment:=4; + end; + else + I:=1; + Increment:=2; + end; + while I0 then + begin + BitsPerSample:=(ScreenDescriptor.PackedFields and GIF_COLORTABLESIZE)+1; + // the global color table immediately follows the screen descriptor + Stream.Seek(3*(1 shl BitsPerSample),spCurrent); + end; + BlockID:=SkipExtensions; + // image found? + if BlockID=GIF_IMAGEDESCRIPTOR then + begin + Stream.Read(ImageDescriptor,sizeof(TImageDescriptor)); + Width:=ImageDescriptor.Width; + if Width=0 then Width:=ScreenDescriptor.ScreenWidth; + Height:=ImageDescriptor.Height; + if Height=0 then Height:=ScreenDescriptor.ScreenHeight; + // if there is a local color table then override the already set one + LocalColorTable:=(ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE)<>0; + if LocalColorTable then BitsPerSample:=(ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE)+1; + Interlaced:=(ImageDescriptor.PackedFields and GIF_INTERLACED)<>0; + end; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + Result:=True; + end; + end; +end; + +//----------------- TRLAGraphic ---------------------------------------------------------------------------------------- + +// This implementation is based on code from Dipl. Ing. Ingo Neumann (ingo@upstart.de, ingo_n@dialup.nacamar.de). + +type + TRLAWindow = packed record + Left,Right,Bottom,Top: smallint; + end; + + TRLAHeader = packed record + Window, // overall image size + Active_window: TRLAWindow; // size of non-zero portion of image (we use this as actual image size) + Frame, // frame number if part of a sequence + Storage_type, // type of image channels (0 - integer data, 1 - float data) + Num_chan, // samples per pixel (usually 3: r, g, b) + Num_matte, // number of matte channels (usually only 1) + Num_aux, // number of auxiliary channels, usually 0 + Revision: smallint; // always $FFFE + Gamma: array[0..15] of Char; // gamma single value used when writing the image + Red_pri: array[0..23] of Char; // used chromaticity for red channel (typical format: "%7.4f %7.4f") + Green_pri: array[0..23] of Char; // used chromaticity for green channel + Blue_pri: array[0..23] of Char; // used chromaticity for blue channel + White_pt: array[0..23] of Char; // used chromaticity for white point + Job_num: integer; // rendering speciifc + Name: array[0..127] of Char; // original file name + Desc: array[0..127] of Char; // a file description + ProgramName: array[0..63] of Char; // name of program which created the image + Machine: array[0..31] of Char; // name of computer on which the image was rendered + User: array[0..31] of Char; // user who ran the creation program of the image + Date: array[0..19] of Char; // creation data of image (ex: Sep 30 12:29 1993) + Aspect: array[0..23] of Char; // aspect format of the file (external resource) + Aspect_ratio: array[0..7] of Char; // float number Width /Height + Chan: array[0..31] of Char; // color space (can be: rgb, xyz, sampled or raw) + Field: smallint; // 0 - non-field rendered data, 1 - field rendered data + Time: array[0..11] of Char; // time needed to create the image (used when rendering) + Filter: array[0..31] of Char; // filter name to post-process image data + Chan_bits, // bits per sample + Matte_type, // type of matte channel (see aux_type) + Matte_bits, // precision of a pixel's matte channel (1..32) + Aux_type, // type of aux channel (0 - integer data; 4 - single (float) data + Aux_bits: smallint; // bits precision of the pixel's aux channel (1..32 bits) + Aux: array[0..31] of Char; // auxiliary channel as either range or depth + Space: array[0..35] of Char; // unused + Next: integer; // offset for next header if multi-frame image + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TRLAGraphic.CanLoad(Stream: PStream): boolean; +var Header: TRLAHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + Result:=(System.Swap(Word(Header.Revision))=$FFFE) and ((LowerCase(Header.Chan)='rgb') or (LowerCase(Header.Chan)='xyz')); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TRLAGraphic.LoadFromStream(Stream: PStream); +var Offsets: TCardinalArray; + RLELength: word; + Line: pointer; + Y,I: Integer; + // RLE buffers + RawBuffer,RedBuffer,GreenBuffer,BlueBuffer,AlphaBuffer: pointer; + Decoder: TRLADecoder; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + // dimension of image, top might be larger than bottom denoting a bottom up image + FBitmap:=NewBitmap(Width,Height); + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + ColorManager.SourceBitsPerSample:=BitsPerSample; + if BitsPerSample>8 then ColorManager.TargetBitsPerSample:=8 else ColorManager.TargetBitsPerSample:=BitsPerSample; + ColorManager.SourceColorScheme:=ColorScheme; + if ColorScheme=csRGBA then ColorManager.TargetColorScheme:=csBGRA else ColorManager.TargetColorScheme:=csBGR; + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + if FileGamma<>1 then + begin + ColorManager.SetGamma(FileGamma); + ColorManager.TargetOptions:=ColorManager.TargetOptions+[coApplyGamma]; + Include(Options,ioUseGamma); + end; + // each scanline is organized in RLE compressed strips whose location in the stream + // is determined by the offsets table + SetLength(Offsets,Height); + Stream.Read(Offsets[0],Height*sizeof(Cardinal)); + for I:=0 to pred(Height) do SwapLong(@Offsets[I],1); + // setup intermediate storage + Decoder:=TRLADecoder.Create; + RawBuffer:=nil; + RedBuffer:=nil; + GreenBuffer:=nil; + BlueBuffer:=nil; + AlphaBuffer:=nil; + try + GetMem(RedBuffer,Width); + GetMem(GreenBuffer,Width); + GetMem(BlueBuffer,Width); + GetMem(AlphaBuffer,Width); + // no go for each scanline + for Y:=0 to pred(Height) do + begin + Stream.Position:=FBasePosition+Offsets[Y]; + if BottomUp then Line:=FBitmap.ScanLine[Integer(Height)-Y-1] else Line:=FBitmap.ScanLine[Y]; + // read channel data to decode + // red + Stream.Read(RLELength,sizeof(RLELength)); + RLELength:=System.Swap(RLELength); + ReallocMem(RawBuffer,RLELength); + Stream.Read(RawBuffer^,RLELength); + Decoder.Decode(RawBuffer,RedBuffer,RLELength,Width); + // green + Stream.Read(RLELength,sizeof(RLELength)); + RLELength:=System.Swap(RLELength); + ReallocMem(RawBuffer,RLELength); + Stream.Read(RawBuffer^,RLELength); + Decoder.Decode(RawBuffer,GreenBuffer,RLELength,Width); + // blue + Stream.Read(RLELength,sizeof(RLELength)); + RLELength:=System.Swap(RLELength); + ReallocMem(RawBuffer,RLELength); + Stream.Read(RawBuffer^,RLELength); + Decoder.Decode(RawBuffer,BlueBuffer,RLELength,Width); + if ColorManager.TargetColorScheme=csBGR then + begin + ColorManager.ConvertRow([RedBuffer,GreenBuffer,BlueBuffer],Line,Width,$FF); + end + else + begin + // alpha + Stream.Read(RLELength,sizeof(RLELength)); + RLELength:=System.Swap(RLELength); + ReallocMem(RawBuffer,RLELength); + Stream.Read(RawBuffer^,RLELength); + Decoder.Decode(RawBuffer,AlphaBuffer,RLELength,Width); + ColorManager.ConvertRow([RedBuffer,GreenBuffer,BlueBuffer,AlphaBuffer],Line,Width,$FF); + end; + end; + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + if Assigned(RedBuffer) then FreeMem(RedBuffer); + if Assigned(GreenBuffer) then FreeMem(GreenBuffer); + if Assigned(BlueBuffer) then FreeMem(BlueBuffer); + if Assigned(AlphaBuffer) then FreeMem(AlphaBuffer); + Decoder.Free; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TRLAGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TRLAHeader; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(Header,sizeof(Header)); + // data is always given in big endian order, so swap data which needs this + SwapHeader(Header); + Options:=[ioBigEndian]; + SamplesPerPixel:=Header.num_chan; + if Header.num_matte=1 then Inc(SamplesPerPixel); + BitsPerSample:=Header.Chan_bits; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + if LowerCase(Header.Chan)='rgb' then + begin + if Header.num_matte>0 then ColorScheme:=csRGBA else ColorScheme:=csRGB; + end + else + if LowerCase(Header.Chan)='xyz' then Exit; + try + FileGamma:=Str2Double(Header.Gamma); + except + end; + Compression:=ctRLE; + // dimension of image, top might be larger than bottom denoting a bottom up image + Width:=Header.Active_window.Right-Header.Active_window.Left+1; + Height:=Abs(Header.Active_window.Bottom-Header.Active_window.Top)+1; + BottomUp:=(Header.Active_window.Bottom-Header.Active_window.Top)<0; + Result:=True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TRLAGraphic.SwapHeader(var Header); +// separate swap method to ease reading the main flow of the LoadFromStream method +begin + with TRLAHeader(Header) do + begin + SwapShort(@Window,4); + SwapShort(@Active_window,4); + Frame:=System.Swap(Frame); + Storage_type:=System.Swap(Storage_type); + Num_chan:=System.Swap(Num_chan); + Num_matte:=System.Swap(Num_matte); + Num_aux:=System.Swap(Num_aux); + Revision:=System.Swap(Revision); + Job_num:=SwapLong(Job_num); + Field:=System.Swap(Field); + Chan_bits:=System.Swap(Chan_bits); + Matte_type:=System.Swap(Matte_type); + Matte_bits:=System.Swap(Matte_bits); + Aux_type:=System.Swap(Aux_type); + Aux_bits:=System.Swap(Aux_bits); + Next:=SwapLong(Next); + end; +end; + +//----------------- TPSDGraphic ---------------------------------------------------------------------------------------- + +const + // color modes + PSD_BITMAP = 0; + PSD_GRAYSCALE = 1; + PSD_INDEXED = 2; + PSD_RGB = 3; + PSD_CMYK = 4; + PSD_MULTICHANNEL = 7; + PSD_DUOTONE = 8; + PSD_LAB = 9; + + PSD_COMPRESSION_NONE = 0; + PSD_COMPRESSION_RLE = 1; // RLE compression (same as TIFF packed bits) + +type + TPSDHeader = packed record + Signature: array[0..3] of Char; // always '8BPS' + Version: word; // always 1 + Reserved: array[0..5] of byte; // reserved, always 0 + Channels: word; // 1..24, number of channels in the image (including alpha) + Rows, + Columns: cardinal; // 1..30000, size of image + Depth: word; // 1,8,16 bits per channel + Mode: word; // color mode (see constants above) + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TPSDGraphic.CanLoad(Stream: PStream): boolean; +var Header: TPSDHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + Result:=(UpperCase(Header.Signature)='8BPS') and (System.Swap(Header.Version)=1); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPSDGraphic.LoadFromStream(Stream: PStream); +var Header: TPSDHeader; + Count: cardinal; + Decoder: TDecoder; + RLELength: array[0..65535] of word; + Y: integer; + BPS: cardinal; // bytes per sample either 1 or 2 for 8 bits per channel and 16 bits per channel respectively + ChannelSize: integer; // size of one channel (taking BPS into account) + Increment: integer; // pointer increment from one line to next + // RLE buffers + Line,RawBuffer, // all image data compressed + Buffer: pointer; // all image data uncompressed + Run1, // running pointer in Buffer 1 + Run2, // etc. + Run3, + Run4: PByte; + RawPalette: array[0..767] of byte; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + Stream.Position:=FBasePosition; + Stream.Read(Header,sizeof(Header)); + // initialize color manager + ColorManager.SourceOptions:=[coNeedByteSwap]; + ColorManager.SourceBitsPerSample:=BitsPerSample; + if BitsPerSample=16 then ColorManager.TargetBitsPerSample:=8 else ColorManager.TargetBitsPerSample:=BitsPerSample; + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + // color space + ColorManager.SourceColorScheme:=ColorScheme; + case ColorScheme of + csG,csIndexed: ColorManager.TargetColorScheme:=ColorScheme; + csRGB: ColorManager.TargetColorScheme:=csBGR; + csRGBA: ColorManager.TargetColorScheme:=csBGRA; + csCMYK: begin + ColorManager.TargetColorScheme:=csBGR; + ColorManager.TargetSamplesPerPixel:=3; + end; + csCIELab: begin + // PSD uses 0..255 for a and b so we need to convert them to -128..127 + ColorManager.SourceOptions:=ColorManager.SourceOptions+[coLabByteRange,coLabChromaOffset]; + ColorManager.TargetColorScheme:=csBGR; + end; + end; + FBitmap:=NewBitmap(Width,Height); + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + // size of palette + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + // setup the palette if necessary, color data immediately follows header + case ColorScheme of + csG: ColorManager.CreateGrayscalePalette(FBitmap,ioMinIsWhite in Options); + csIndexed: + begin + Stream.Read(RawPalette,Count); + Count:=Count div 3; + ColorManager.CreateColorPalette(FBitmap,[@RawPalette,@RawPalette[Count],@RawPalette[2*Count]],pfPlane8Triple,Count,False); + end; + end; + // skip resource and layers section + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + Stream.Seek(Count,spCurrent); + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + // +2 in order to skip the following compression value + Stream.Seek(Count+2,spCurrent); + // now read out image data + RawBuffer:=nil; + if Compression=ctPackedBits then + begin + Decoder:=TPackbitsRLEDecoder.Create; + Stream.Read(RLELength,2*Height*Channels); + SwapShort(@RLELength[0],Height*Channels); + end + else Decoder:=nil; + try + case ColorScheme of + csG,csIndexed: + begin + // very simple format here, we don't need the color conversion manager + if Assigned(Decoder) then + begin + // determine whole compressed size + Count:=0; + for Y:=0 to pred(Height) do Inc(Count,RLELength[Y]); + GetMem(RawBuffer,Count); + try + Stream.Read(RawBuffer^,Count); + Run1:=RawBuffer; + for Y:=0 to pred(Height) do + begin + Count:=RLELength[Y]; + Line:=FBitmap.ScanLine[Y]; + Decoder.Decode(Pointer(Run1),Line,Count,Width); + Inc(Run1,Count); + end; + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end + else // uncompressed data + for Y:=0 to pred(Height) do + begin + Stream.Read(FBitmap.ScanLine[Y]^,Width); + end; + end; + csRGB,csRGBA,csCMYK,csCIELab: + begin + // Data is organized in planes. This means first all red rows, then + // all green and finally all blue rows. + BPS:=BitsPerSample div 8; + ChannelSize:=BPS*Width*Height; + GetMem(Buffer,Channels*ChannelSize); + try + // first run: load image data and decompress it if necessary + if Assigned(Decoder) then + begin + // determine whole compressed size + Count:=0; + for Y:=0 to High(RLELength) do Inc(Count,RLELength[Y]); + Count:=Count*Cardinal(BPS); + GetMem(RawBuffer,Count); + try + Stream.Read(RawBuffer^,Count); + Decoder.Decode(RawBuffer,Buffer,Count,Channels*ChannelSize); + finally + if Assigned(RawBuffer) then FreeMem(RawBuffer); + end; + end + else Stream.Read(Buffer^,Channels*ChannelSize); + Increment:=BPS*Width; + // second run: put data into image (convert color space if necessary) + case ColorScheme of + csRGB: + begin + Run1:=Buffer; + Run2:=Run1; + Inc(Run2,ChannelSize); + Run3:=Run2; + Inc(Run3,ChannelSize); + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([Run1,Run2,Run3],FBitmap.ScanLine[Y],Width,$FF); + Inc(Run1,Increment); + Inc(Run2,Increment); + Inc(Run3,Increment); + end; + end; + csRGBA: + begin + Run1:=Buffer; + Run2:=Run1; + Inc(Run2,ChannelSize); + Run3:=Run2; + Inc(Run3,ChannelSize); + Run4:=Run3; + Inc(Run4,ChannelSize); + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([Run1,Run2,Run3,Run4],FBitmap.ScanLine[Y],Width,$FF); + Inc(Run1,Increment); + Inc(Run2,Increment); + Inc(Run3,Increment); + Inc(Run4,Increment); + end; + end; + csCMYK: + begin + // Photoshop CMYK values are given with 0 for maximum values, but the + // (general) CMYK conversion works with 255 as maxium value. Hence we must reverse + // all entries in the buffer. + Run1:=Buffer; + for Y:=1 to 4*ChannelSize do + begin + Run1^:=255-Run1^; + Inc(Run1); + end; + Run1:=Buffer; + Run2:=Run1; + Inc(Run2,ChannelSize); + Run3:=Run2; + Inc(Run3,ChannelSize); + Run4:=Run3; + Inc(Run4,ChannelSize); + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([Run1,Run2,Run3,Run4],FBitmap.ScanLine[Y],Width,$FF); + Inc(Run1,Increment); + Inc(Run2,Increment); + Inc(Run3,Increment); + Inc(Run4,Increment); + end; + end; + csCIELab: + begin + Run1:=Buffer; + Run2:=Run1; + Inc(Run2,ChannelSize); + Run3:=Run2; + Inc(Run3,ChannelSize); + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([Run1,Run2,Run3],FBitmap.ScanLine[Y],Width,$FF); + Inc(Run1,Increment); + Inc(Run2,Increment); + Inc(Run3,Increment); + end; + end; + end; + finally + if Assigned(Buffer) then FreeMem(Buffer); + end; + end; + end; + finally + Decoder.Free; + end; + end; + end + else GraphicExError(1{gesInvalidImage},['PSD or PDD']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPSDGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TPSDHeader; + Dummy: word; + Count: cardinal; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + with FImageProperties do + begin + Stream.Read(Header,sizeof(Header)); + if Header.Signature='8BPS' then + begin + with Header do + begin + // PSD files are big endian only + Channels:=System.Swap(Channels); + Rows:=SwapLong(Rows); + Columns:=SwapLong(Columns); + Depth:=System.Swap(Depth); + Mode:=System.Swap(Mode); + end; + Options:=[ioBigEndian]; + // initialize color manager + BitsPerSample:=Header.Depth; + Channels:=Header.Channels; + // 1..24 channels are supported in PSD files, we can only use 4. + // The documentation states that main image data (rgb(a), cmyk etc.) is always + // written as first channels in their component order. + if Channels>4 then SamplesPerPixel:=4 else SamplesPerPixel:=Channels; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + // color space + case Header.Mode of + PSD_DUOTONE, // duo tone should be handled as grayscale + PSD_GRAYSCALE: ColorScheme:=csG; + PSD_BITMAP: // B&W + begin + ColorScheme:=csG; + Include(Options,ioMinIsWhite); + end; + PSD_INDEXED: // 8 bits only are assumed because 16 bit wouldn't make sense here + ColorScheme:=csIndexed; + PSD_MULTICHANNEL, + PSD_RGB: + if Header.Channels=3 then ColorScheme:=csRGB else ColorScheme:=csRGBA; + PSD_CMYK: ColorScheme:=csCMYK; + PSD_LAB: ColorScheme:=csCIELab; + end; + Width:=Header.Columns; + Height:=Header.Rows; + // size of palette + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + // skip palette (count is always given, might be 0 however, e.g. for RGB) + Stream.Seek(Count,spCurrent); + // skip resource and layers section + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + Stream.Seek(Count,spCurrent); + Stream.Read(Count,sizeof(Count)); + Count:=SwapLong(Count); + Stream.Seek(Count,spCurrent); + Stream.Read(Dummy,sizeof(Dummy)); + if System.Swap(Dummy)=1 then Compression:=ctPackedBits else Compression:=ctNone; + Result:=True; + end; + end; +end; + +//----------------- TPSPGraphic ---------------------------------------------------------------------------------------- + +const + // block identifiers + PSP_IMAGE_BLOCK = 0; // General Image Attributes Block (main) + PSP_CREATOR_BLOCK = 1; // Creator Data Block (main) + PSP_COLOR_BLOCK = 2; // Color Palette Block (main and sub) + PSP_LAYER_START_BLOCK = 3; // Layer Bank Block (main) + PSP_LAYER_BLOCK = 4; // Layer Block (sub) + PSP_CHANNEL_BLOCK = 5; // Channel Block (sub) + PSP_SELECTION_BLOCK = 6; // Selection Block (main) + PSP_ALPHA_BANK_BLOCK = 7; // Alpha Bank Block (main) + PSP_ALPHA_CHANNEL_BLOCK = 8; // Alpha Channel Block (sub) + PSP_THUMBNAIL_BLOCK = 9; // Thumbnail Block (main) + PSP_EXTENDED_DATA_BLOCK = 10; // Extended Data Block (main) + PSP_TUBE_BLOCK = 11; // Picture Tube Data Block (main) + PSP_ADJUSTMENT_EXTENSION_BLOCK = 12; // Adjustment Layer Extension Block (sub) + PSP_VECTOR_EXTENSION_BLOCK = 13; // Vector Layer Extension Block (sub) + PSP_SHAPE_BLOCK = 14; // Vector Shape Block (sub) + PSP_PAINTSTYLE_BLOCK = 15; // Paint Style Block (sub) + PSP_COMPOSITE_IMAGE_BANK_BLOCK = 16; // Composite Image Bank (main) + PSP_COMPOSITE_ATTRIBUTES_BLOCK = 17; // Composite Image Attributes (sub) + PSP_JPEG_BLOCK = 18; // JPEG Image Block (sub) + + // bitmap types + PSP_DIB_IMAGE = 0; // Layer color bitmap + PSP_DIB_TRANS_MASK = 1; // Layer transparency mask bitmap + PSP_DIB_USER_MASK = 2; // Layer user mask bitmap + PSP_DIB_SELECTION= 3; // Selection mask bitmap + PSP_DIB_ALPHA_MASK = 4; // Alpha channel mask bitmap + PSP_DIB_THUMBNAIL = 5; // Thumbnail bitmap + PSP_DIB_THUMBNAIL_TRANS_MASK = 6; // Thumbnail transparency mask + PSP_DIB_ADJUSTMENT_LAYER = 7; // Adjustment layer bitmap + PSP_DIB_COMPOSITE = 8; // Composite image bitmap + PSP_DIB_COMPOSITE_TRANS_MASK = 9; // Composite image transparency + + // composite image type + PSP_IMAGE_COMPOSITE = 0; // Composite Image + PSP_IMAGE_THUMBNAIL = 1; // Thumbnail Image + + // graphic contents flags + PSP_GC_RASTERLAYERS = 1; // At least one raster layer + PSP_GC_VectorLayers = 2; // At least one vector layer + PSP_GC_ADJUSTMENTLAYERS = 4; // At least one adjustment layer + // Additional attributes + PSP_GC_THUMBNAIL = $01000000; // Has a thumbnail + PSP_GC_THUMBNAILTRANSPARENCY = $02000000; // Thumbnail transp. + PSP_GC_COMPOSITE = $04000000; // Has a composite image + PSP_GC_COMPOSITETRANSPARENCY = $08000000; // Composite transp. + PSP_GC_FLATIMAGE = $10000000; // Just a background + PSP_GC_SELECTION = $20000000; // Has a selection + PSP_GC_FLOATINGSELECTIONLAYER = $40000000; // Has float. selection + PSP_GC_ALPHACHANNELS = $80000000; // Has alpha channel(s) + + // character style flags + PSP_STYLE_ITALIC = 1; // Italic property bit + PSP_STYLE_STRUCK = 2; // Strike-out property bit + PSP_STYLE_UNDERLINED = 4; // Underlined property bit + + // layer flags + PSP_LAYER_VISIBLEFLAG = 1; // Layer is visible + PSP_LAYER_MASKPRESENCEFLAG = 2; // Layer has a mask + + // Shape property flags + PSP_SHAPE_ANTIALIASED = 1; // Shape is anti-aliased + PSP_SHAPE_Selected = 2; // Shape is selected + PSP_SHAPE_Visible = 4; // Shape is visible + + // Polyline node type flags + PSP_NODE_UNCONSTRAINED = 0; // Default node type + PSP_NODE_SMOOTH = 1; // Node is smooth + PSP_NODE_SYMMETRIC = 2; // Node is symmetric + PSP_NODE_ALIGNED = 4; // Node is aligned + PSP_NODE_ACTIVE = 8; // Node is active + PSP_NODE_LOCKED = 16; // Node is locked (PSP doc says 0x16 here, but this seems to be a typo) + PSP_NODE_SELECTED = 32; // Node is selected (PSP doc says 0x32 here) + PSP_NODE_VISIBLE = 64; // Node is visible (PSP doc says 0x64 here) + PSP_NODE_CLOSED = 128; // Node is closed (PSP doc says 0x128 here) + + // Blend modes + LAYER_BLEND_NORMAL = 0; + LAYER_BLEND_DARKEN = 1; + LAYER_BLEND_LIGHTEN = 2; + LAYER_BLEND_HUE = 3; + LAYER_BLEND_SATURATION = 4; + LAYER_BLEND_COLOR = 5; + LAYER_BLEND_LUMINOSITY = 6; + LAYER_BLEND_MULTIPLY = 7; + LAYER_BLEND_SCREEN = 8; + LAYER_BLEND_DISSOLVE = 9; + LAYER_BLEND_OVERLAY = 10; + LAYER_BLEND_HARD_LIGHT = 11; + LAYER_BLEND_SOFT_LIGHT = 12; + LAYER_BLEND_DIFFERENCE = 130; + LAYER_BLEND_DODGE = 14; + LAYER_BLEND_BURN = 15; + LAYER_BLEND_EXCLUSION = 16; + LAYER_BLEND_ADJUST = 255; + + // Adjustment layer types + PSP_ADJUSTMENT_NONE = 0; // Undefined adjustment layer type + PSP_ADJUSTMENT_LEVEL = 1; // Level adjustment + PSP_ADJUSTMENT_CURVE = 2; // Curve adjustment + PSP_ADJUSTMENT_BRIGHTCONTRAST = 3; // Brightness-contrast adjustment + PSP_ADJUSTMENT_COLORBAL = 4; // Color balance adjustment + PSP_ADJUSTMENT_HSL = 5; // HSL adjustment + PSP_ADJUSTMENT_CHANNELMIXER = 6; // Channel mixer adjustment + PSP_ADJUSTMENT_INVERT = 7; // Invert adjustment + PSP_ADJUSTMENT_THRESHOLD = 8; // Threshold adjustment + PSP_ADJUSTMENT_POSTER = 9; // Posterize adjustment + + // Vector shape types + PSP_VST_Unknown = 0; // Undefined vector type + PSP_VST_TEXT = 1; // Shape represents lines of text + PSP_VST_POLYLINE = 2; // Shape represents a multiple segment line + PSP_VST_ELLIPSE = 3; // Shape represents an ellipse (or circle) + PSP_VST_POLYGON = 4; // Shape represents a closed polygon + + // Text element types + PSP_TET_UNKNOWN = 0; // Undefined text element type + PSP_TET_CHAR = 1; // A single character code + PSP_TET_CHARSTYLE = 2; // A character style change + PSP_TET_LINESTYLE = 3; // A line style change + + // Text alignment types + PSP_TAT_LEFT = 0; // Left text alignment + PSP_TAT_CENTER = 1; // Center text alignment + PSP_TAT_RIGHT = 2; // Right text alignment + + // Paint style types + PSP_STYLE_NONE = 0; // Undefined paint style + PSP_STYLE_COLOR = 1; // Paint using color (RGB or palette index) + PSP_STYLE_GRADIENT = 2; // Paint using gradient + + // Channel types + PSP_CHANNEL_COMPOSITE = 0; // Channel of single channel bitmap + PSP_CHANNEL_RED = 1; // Red channel of 24 bit bitmap + PSP_CHANNEL_GREEN = 2; // Green channel of 24 bit bitmap + PSP_CHANNEL_BLUE = 3; // Blue channel of 24 bit bitmap + + // Resolution metrics + PSP_METRIC_UNDEFINED = 0; // Metric unknown + PSP_METRIC_INCH = 1; // Resolution is in inches + PSP_METRIC_CM = 2; // Resolution is in centimeters + + // Compression types + PSP_COMP_NONE = 0; // No compression + PSP_COMP_RLE = 1; // RLE compression + PSP_COMP_LZ77 = 2; // LZ77 compression + PSP_COMP_JPEG = 3; // JPEG compression (only used by thumbnail and composite image) + + // Picture tube placement mode + PSP_TPM_Random = 0; // Place tube images in random intervals + PSPS_TPM_Constant = 1; // Place tube images in constant intervals + + // Tube selection mode + PSP_TSM_RANDOM =0; // Randomly select the next image in tube to display + PSP_TSM_INCREMENTAL = 1; // Select each tube image in turn + PSP_TSM_ANGULAR = 2; // Select image based on cursor direction + PSP_TSM_PRESSURE = 3; // Select image based on pressure (from pressure-sensitive pad) + PSP_TSM_VELOCITY = 4; // Select image based on cursor speed + + // Extended data field types + PSP_XDATA_TRNS_INDEX = 0; // Transparency index field + + // Creator field types + PSP_CRTR_FLD_TITLE = 0; // Image document title field + PSP_CRTR_FLD_CRT_DATE = 1; // Creation date field + PSP_CRTR_FLD_MOD_DATE = 2; // Modification date field + PSP_CRTR_FLD_ARTIST = 3; // Artist name field + PSP_CRTR_FLD_CPYRGHT = 4; // Copyright holder name field + PSP_CRTR_FLD_DESC = 5; // Image document description field + PSP_CRTR_FLD_APP_ID = 6; // Creating app id field + PSP_CRTR_FLD_APP_VER = 7; // Creating app version field + + // Creator application identifier + PSP_CREATOR_APP_UNKNOWN = 0; // Creator application unknown + PSP_CREATOR_APP_PAINT_SHOP_PRO = 1; // Creator is Paint Shop Pro + + // Layer types (file version 3) + PSP_LAYER_NORMAL = 0; // Normal layer + PSP_LAYER_FLOATING_SELECTION = 1; // Floating selection layer + + // Layer types (file version 4) + PSP_LAYER_UNDEFINED = 0; // Undefined layer type + PSP_LAYER_RASTER = 1; // Standard raster layer + PSP_LAYER_FLOATINGRASTERSELECTION = 2; // Floating selection (raster layer) + PSP_LAYER_Vector = 3; // Vector layer + PSP_LAYER_ADJUSTMENT = 4; // Adjustment layer + + MagicID = 'Paint Shop Pro Image File'; + +type + // These block header structures are here for informational purposes only because the data of those + // headers is read member by member to generalize code for the different file versions + TPSPBlockHeader3 = packed record // block header file version 3 + HeaderIdentifier: array[0..3] of Char; // i.e. "~BK" followed by a zero byte + BlockIdentifier: word; // one of the block identifiers + InitialChunkLength, // length of the first sub chunk header or similar + TotalBlockLength: cardinal; // length of this block excluding this header + end; + + TPSPBlockHeader4 = packed record // block header file version 4 + HeaderIdentifier: array[0..3] of Char; // i.e. "~BK" followed by a zero byte + BlockIdentifier: word; // one of the block identifiers + TotalBlockLength: cardinal; // length of this block excluding this header + end; + + TPSPColorPaletteInfoChunk = packed record + EntryCount: cardinal; // number of entries in the palette + end; + + TPSPColorPaletteChunk = array[0..255] of TRGBQuad; // might actually be shorter + + TPSPChannelInfoChunk = packed record + CompressedSize, + UncompressedSize: cardinal; + BitmapType, // one of the bitmap types + ChannelType: word; // one of the channel types + end; + + // PSP defines a channel content chunk which is just a bunch of bytes (size is CompressedSize). + // There is no sense to define this record type here. + + TPSPFileHeader = packed record + Signature: array[0..31] of Char; // the string "Paint Shop Pro Image File\n\x1a", padded with zeroes + MajorVersion, + MinorVersion: word; + end; + + TPSPImageAttributes = packed record + Width,Height: integer; + Resolution: double; // Number of pixels per metric + ResolutionMetric: byte; // Metric used for resolution (one of the metric constants) + Compression, // compression type of image (not thumbnail, it has its own compression) + BitDepth, // The bit depth of the color bitmap in each Layer of the image document + // (must be 1, 4, 8 or 24). + PlaneCount: word; // Number of planes in each layer of the image document (usually 1) + ColorCount: cardinal; // number of colors in each layer (2^bit depth) + GreyscaleFlag: boolean; // Indicates whether the color bitmap in each layer of image document is a + // greyscale (False = not greyscale, True = greyscale). + TotalImageSize: cardinal; // Sum of the sizes of all layer color bitmaps. + ActiveLayer: integer; // Identifies the layer that was active when the image document was saved. + LayerCount: word; // Number of layers in the document. + GraphicContents: cardinal; // A series of flags that helps define the image's graphic contents. + end; + + TPSPLayerInfoChunk = packed record + //LayerName: array[0..255] of Char; // Name of layer (in ASCII text). Has been replaced in version 4 + // by a Delphi like short string (length word and variable length string) + LayerType: byte; // Type of layer. + ImageRectangle, // Rectangle defining image border. + SavedImageRectangle: TRect; // Rectangle within image rectangle that contains "significant" data + // (only the contents of this rectangle are saved to the file). + LayerOpacity: byte; // Overall layer opacity. + BlendingMode: byte; // Mode to use when blending layer. + Visible: boolean; // TRUE if layer was visible at time of save, FALSE otherwise. + TransparencyProtected: boolean; // TRUE if transparency is protected. + LinkGroupIdentifier: byte; // Identifies group to which this layer belongs. + MaskRectangle, // Rectangle defining user mask border. + SavedMaskRectangle: TRect; // Rectangle within mask rectangle that contains "significant" data + // (only the contents of this rectangle are saved to the file). + MaskLinked: boolean; // TRUE if mask linked to layer (i.e., mask moves relative to layer) + MaskDisabled: boolean; // TRUE if mask is disabled, FALSE otherwise. + InvertMask: boolean; // TRUE if mask should be inverted when the layer is merged, FALSE otherwise. + BlendRangeCount: word; // Number of valid source-destination field pairs to follow (note, there are + // currently always 5 such pairs, but they are not necessarily all valid). + SourceBlendRange1, // First source blend range value. + DestinationBlendRange1, // First destination blend range value. + SourceBlendRange2, + DestinationBlendRange2, + SourceBlendRange3, + DestinationBlendRange3, + SourceBlendRange4, + DestinationBlendRange4, + SourceBlendRange5, + DestinationBlendRange5: array[0..3] of byte; + // these fields are obsolete since file version 4 because there's an own chunk for them + // BitmapCount: Word; // Number of bitmaps to follow. + // ChannelCount: Word; // Number of channels to follow. + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TPSPGraphic.CanLoad(Stream: PStream): boolean; +var Header: TPSPFileHeader; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Header); + if Result then + begin + Stream.Read(Header,sizeof(Header)); + Result:=(StrLIComp(Header.Signature,MagicID,Length(MagicID))=0) and (Header.MajorVersion>=3); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPSPGraphic.LoadFromStream(Stream: PStream); +var Header: TPSPFileHeader; + Image: TPSPImageAttributes; + // to use the code below for file 3 and 4 I read the parts of the block header + // separately instead as a structure + HeaderIdentifier: array[0..3] of Char; // i.e. "~BK" followed by a zero byte + BlockIdentifier: word; // one of the block identifiers + InitialChunkLength, // length of the first sub chunk header or similar + TotalBlockLength: cardinal; // length of this block excluding this header + LastPosition,ChunkSize: cardinal; + LayerInfo: TPSPLayerInfoChunk; + ChannelInfo: TPSPChannelInfoChunk; + LayerName: string; + NameLength: word; + NextLayerPosition, + NextMainBlock: integer; + // file version 4 specific data + BitmapCount,ChannelCount: word; + // load and decoding of image data + R,G,B,C: PByte; + RedBuffer,GreenBuffer,BlueBuffer,CompBuffer: pointer; + X,Y,Index,RowSize: integer; // size in bytes of one scanline + // other data + RawPalette: array[0..1023] of byte; + + //--------------- local functions ------------------------------------------- + function ReadBlockHeader: boolean; + // Fills in the block header variables according to the file version. + // Returns True if a block header could be read otherwise False (stream end). + begin + Result:=Stream.Position3 then Stream.Read(ChunkSize,sizeof(ChunkSize)); + Stream.Read(ChannelInfo,sizeof(ChannelInfo)); + case ChannelInfo.ChannelType of + PSP_CHANNEL_COMPOSITE: // single channel bitmap (indexed or transparency mask) + begin + GetMem(CompBuffer,ChannelInfo.UncompressedSize); + if Image.Compression<>PSP_COMP_NONE then ReadAndDecompress(CompBuffer) else Stream.Read(CompBuffer^,ChannelInfo.CompressedSize); + end; + PSP_CHANNEL_RED: // red channel of 24 bit bitmap + begin + GetMem(RedBuffer,ChannelInfo.UncompressedSize); + if Image.Compression<>PSP_COMP_NONE then ReadAndDecompress(RedBuffer) else Stream.Read(RedBuffer^,ChannelInfo.CompressedSize); + end; + PSP_CHANNEL_GREEN: + begin + GetMem(GreenBuffer,ChannelInfo.UncompressedSize); + if Image.Compression<>PSP_COMP_NONE then ReadAndDecompress(GreenBuffer) else Stream.Read(GreenBuffer^,ChannelInfo.CompressedSize); + end; + PSP_CHANNEL_BLUE: + begin + GetMem(BlueBuffer,ChannelInfo.UncompressedSize); + if Image.Compression<>PSP_COMP_NONE then ReadAndDecompress(BlueBuffer) else Stream.Read(BlueBuffer^,ChannelInfo.CompressedSize); + end; + end; + end; + //--------------- end local functions --------------------------------------- + +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + if ReadImageProperties(Stream,0) then + begin + Stream.Position:=FBasePosition; + RedBuffer:=nil; + GreenBuffer:=nil; + BlueBuffer:=nil; + with FImageProperties do + try + // Note: To be robust with future PSP images any reader must be able to skip data + // which it doesn't know instead of relying on the size of known structures. + // Hence there's some extra work needed with the stream (mainly to keep the + // current position before a chunk is read and advancing the stream using the + // chunk size field). + Stream.Read(Header,sizeof(Header)); + // read general image attribute block + ReadBlockHeader; + LastPosition:=Stream.Position; + if Version>3 then Stream.Read(ChunkSize,sizeof(ChunkSize)); + Stream.Read(Image,sizeof(Image)); + Stream.Position:=LastPosition+TotalBlockLength; + FBitmap:=NewBitmap(Width,Height); + with Image do + begin + ColorManager.SourceOptions:=[]; + ColorManager.SourceBitsPerSample:=BitsPerSample; + ColorManager.TargetBitsPerSample:=BitsPerSample; + ColorManager.SourceSamplesPerPixel:=SamplesPerPixel; + ColorManager.TargetSamplesPerPixel:=SamplesPerPixel; + ColorManager.SourceColorScheme:=ColorScheme; + if ColorScheme=csRGB then ColorManager.TargetColorScheme:=csBGR else ColorManager.TargetColorScheme:=ColorScheme; + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + end; + // set bitmap properties + RowSize:=0; // make compiler quiet + case BitsPerSample of + 1: RowSize:=(Image.Width+7) div 8; + 4: RowSize:=Image.Width div 2+1; + 8: RowSize:=Image.Width; + else + GraphicExError(2{gesInvalidColorFormat},['PSP']); + end; + // go through main blocks and read what is needed + repeat + if not ReadBlockHeader then Break; + NextMainBlock:=Stream.Position+Integer(TotalBlockLength); + // no more blocks? + if HeaderIdentifier[0]<>'~' then Break; + case BlockIdentifier of + PSP_COMPOSITE_IMAGE_BANK_BLOCK: + begin + // composite image block, if present then it must appear before the layer start block + // and represents a composition of several layers + + // do not need to read anything further + //Break; + end; + PSP_LAYER_START_BLOCK: + repeat + if not ReadBlockHeader then Break; + // calculate start of next (layer) block in case we need to skip this one + NextLayerPosition:=Stream.Position+Integer(TotalBlockLength); + // if all layers have been considered the break loop to continue with other blocks if necessary + if BlockIdentifier<>PSP_LAYER_BLOCK then Break; + // layer information chunk + if Version>3 then + begin + LastPosition:=Stream.Position; + Stream.Read(ChunkSize,sizeof(ChunkSize)); + Stream.Read(NameLength,sizeof(NameLength)); + SetLength(LayerName,NameLength); + if NameLength>0 then Stream.Read(LayerName[1],NameLength); + Stream.Read(LayerInfo,sizeof(LayerInfo)); + Stream.Position:=LastPosition+ChunkSize; + // continue only with undefined or raster chunks + if not (LayerInfo.LayerType in [PSP_LAYER_UNDEFINED,PSP_LAYER_RASTER]) then + begin + Stream.Position:=NextLayerPosition; + Continue; + end; + // in file version 4 there's also an additional bitmap chunk which replaces + // two fields formerly located in the LayerInfo chunk + LastPosition:=Stream.Position; + Stream.Read(ChunkSize,sizeof(ChunkSize)); + end + else + begin + SetLength(LayerName,256); + Stream.Read(LayerName[1],256); + Stream.Read(LayerInfo,sizeof(LayerInfo)); + // continue only with normal (raster) chunks + if LayerInfo.LayerType<>PSP_LAYER_NORMAL then + begin + Stream.Position:=NextLayerPosition; + Continue; + end; + end; + Stream.Read(BitmapCount,sizeof(BitmapCount)); + Stream.Read(ChannelCount,sizeof(ChannelCount)); + // But now we can reliably say whether we have an alpha channel or not. + // This kind of information can only be read very late and causes us to + // possibly reallocate the entire image (because it is copied by the VCL + // when changing the pixel format). + // I don't know another way (preferably before the size of the image is set). + if ChannelCount>3 then + begin + ColorManager.TargetColorScheme:=csBGRA; + FBitmap.PixelFormat:=pf32Bit; + end; + if Version>3 then Stream.Position:=LastPosition+ChunkSize; + // allocate memory for all channels and read raw data + for X:=0 to pred(ChannelCount) do ReadChannelData; + R:=RedBuffer; + G:=GreenBuffer; + B:=BlueBuffer; + C:=CompBuffer; + if ColorManager.TargetColorScheme in [csIndexed,csG] then + begin + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([C],FBitmap.ScanLine[Y],Width,$FF); + Inc(C,RowSize); + end; + end + else + begin + for Y:=0 to pred(Height) do + begin + ColorManager.ConvertRow([R,G,B,C],FBitmap.ScanLine[Y],Width,$FF); + Inc(R,RowSize); + Inc(G,RowSize); + Inc(B,RowSize); + Inc(C,RowSize); + end; + end; + // after the raster layer has been read there's no need to loop further + Break; + until False; // layer loop + PSP_COLOR_BLOCK: // color palette block (this is also present for gray scale and b&w images) + begin + if Version>3 then Stream.Read(ChunkSize,sizeof(ChunkSize)); + Stream.Read(Index,sizeof(Index)); + Stream.Read(RawPalette,Index*sizeof(TRGBQuad)); + ColorManager.CreateColorPalette(FBitmap,[@RawPalette],pfInterlaced8Quad,Index,True); + end; + end; + // explicitly set stream position to next main block as we might have read a block only partially + Stream.Position:=NextMainBlock; + until False; // main block loop + finally + if Assigned(RedBuffer) then FreeMem(RedBuffer); + if Assigned(GreenBuffer) then FreeMem(GreenBuffer); + if Assigned(BlueBuffer) then FreeMem(BlueBuffer); + end; + end + else GraphicExError(1{gesInvalidImage},['PSP']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPSPGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Header: TPSPFileHeader; + Image: TPSPImageAttributes; + // to use the code below for file 3 and 4 I read the parts of the block header + // separately instead as a structure + HeaderIdentifier: array[0..3] of Char; // i.e. "~BK" followed by a zero byte + BlockIdentifier: word; // one of the block identifiers + InitialChunkLength, // length of the first sub chunk header or similar + TotalBlockLength: cardinal; // length of this block excluding this header + LastPosition,ChunkSize: cardinal; + + //--------------- local functions ------------------------------------------- + function ReadBlockHeader: Boolean; + // Fills in the block header variables according to the file version. + // Returns True if a block header could be read otherwise False (stream end). + begin + Result:=Stream.Position=3) then + begin + Version:=Header.MajorVersion; + // read general image attribute block + ReadBlockHeader; + LastPosition:=Stream.Position; + if Header.MajorVersion>3 then Stream.Read(ChunkSize,sizeof(ChunkSize)); + Stream.Read(Image,sizeof(Image)); + Stream.Position:=LastPosition+TotalBlockLength; + if Image.BitDepth=24 then + begin + BitsPerSample:=8; + SamplesPerPixel:=3; + ColorScheme:=csRGB; // an alpha channel might exist, this is determined by the layer's channel count + end + else + begin + BitsPerSample:=Image.BitDepth; + SamplesPerPixel:=1; + if Image.GreyscaleFlag then ColorScheme:=csG else ColorScheme:=csIndexed; + end; + BitsPerPixel:=BitsPerSample*SamplesPerPixel; + Width:=Image.Width; + Height:=Image.Height; + case Image.Compression of + PSP_COMP_NONE: Compression:=ctNone; + PSP_COMP_RLE: Compression:=ctRLE; + PSP_COMP_LZ77: Compression:=ctLZ77; + PSP_COMP_JPEG: Compression:=ctJPEG; + else + Compression:=ctUnknown; + end; + XResolution:=Image.Resolution; + if Image.ResolutionMetric=PSP_METRIC_CM then XResolution:=XResolution*2.54; + YResolution:=XResolution; + Result:=True; + end; + end; +end; + +//----------------- TPNGGraphic ---------------------------------------------------------------------------------------- + +const + PNGMagic: array[0..7] of Byte = (137,80,78,71,13,10,26,10); + + // recognized and handled chunk types + IHDR = 'IHDR'; + IDAT = 'IDAT'; + IEND = 'IEND'; + PLTE = 'PLTE'; + gAMA = 'gAMA'; + tRNS = 'tRNS'; + bKGD = 'bKGD'; + + CHUNKMASK = $20; // used to check bit 5 in chunk types + +type + // The following chunks structures are those which appear in the data field of the general chunk structure + // given above. + + // chunk type: 'IHDR' + PIHDRChunk = ^TIHDRChunk; + TIHDRChunk = packed record + Width, + Height: cardinal; + BitDepth, // bits per sample (allowed are 1,2,4,8 and 16) + ColorType, // combination of: + // 1 - palette used + // 2 - colors used + // 4 - alpha channel used + // allowed values are: + // 0 - gray scale (allowed bit depths are: 1,2,4,8,16) + // 2 - RGB (8,16) + // 3 - palette (1,2,4,8) + // 4 - gray scale with alpha (8,16) + // 6 - RGB with alpha (8,16) + Compression, // 0 - LZ77, others are not yet defined + Filter, // filter mode 0 is the only one currently defined + Interlaced: byte; // 0 - not interlaced, 1 - Adam7 interlaced + end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TPNGGraphic.CanLoad(Stream: PStream): boolean; +var Magic: array[0..7] of byte; + LastPosition: cardinal; +begin + LastPosition:=Stream.Position; + Result:=(Stream.Size-Stream.Position)>sizeof(Magic); + if Result then + begin + Stream.Read(Magic,sizeof(Magic)); + Result:=CompareMem(@Magic,@PNGMagic,8); + end; + Stream.Position:=LastPosition; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPNGGraphic.IsChunk(ChunkType: TChunkType): boolean; +// determines, independant of the cruxial 5ths bits in each "letter", whether the +// current chunk type in the header is the same as the given chunk type +const + Mask = not $20202020; +begin + Result:=(Cardinal(FHeader.ChunkType) and Mask)=(Cardinal(ChunkType) and Mask); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPNGGraphic.LoadAndSwapHeader: cardinal; +// read next chunk header and swap fields to little endian, +// returns the intial CRC value for following checks +begin + FStream.Read(FHeader,sizeof(FHeader)); + Result:=CRC32(0,@FHeader.ChunkType,4); + FHeader.Length:=SwapLong(FHeader.Length); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function PaethPredictor(A,B,C: byte): byte; +var P,PA,PB,PC: integer; +begin + // a = left, b = above, c = upper left + P:=A+B-C; // initial estimate + PA:=Abs(P-A); // distances to a, b, c + PB:=Abs(P-B); + PC:=Abs(P-C); + // return nearest of a, b, c, breaking ties in order a, b, c + if (PA<=PB) and (PA<=PC) then Result:=A else + if PB<=PC then Result:=B else Result:=C; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPNGGraphic.ApplyFilter(Filter: byte; Line,PrevLine,Target: PByte; BPP,BytesPerRow: integer); +// Applies the filter given in Filter to all bytes in Line (eventually using PrevLine). +// Note: The filter type is assumed to be of filter mode 0, as this is the only one currently +// defined in PNG. +// In opposition to the PNG documentation different identifiers are used here. +// Raw refers to the current, not yet decoded value. Decoded refers to the current, already +// decoded value (this one is called "raw" in the docs) and Prior is the current value in the +// previous line. For the Paeth prediction scheme a fourth pointer is used (PriorDecoded) to describe +// the value in the previous line but less the BPP value (Prior[x - BPP]). +var I: integer; + Raw,Decoded,Prior,PriorDecoded,TargetRun: PByte; +begin + case Filter of + 0: Move(Line^,Target^,BytesPerRow); // no filter, just copy data + 1: begin // subtraction filter + Raw:=Line; + TargetRun:=Target; + // Transfer BPP bytes without filtering. This mimics the effect of bytes left to the + // scanline being zero. + Move(Raw^,TargetRun^,BPP); + // now do rest of the line + Decoded:=TargetRun; + Inc(Raw,BPP); + Inc(TargetRun,BPP); + Dec(BytesPerRow,BPP); + while BytesPerRow>0 do + begin + TargetRun^:=Byte(Raw^+Decoded^); + Inc(Raw); + Inc(Decoded); + Inc(TargetRun); + Dec(BytesPerRow); + end; + end; + 2: begin // Up filter + Raw:=Line; + Prior:=PrevLine; + TargetRun:=Target; + while BytesPerRow>0 do + begin + TargetRun^:=Byte(Raw^+Prior^); + Inc(Raw); + Inc(Prior); + Inc(TargetRun); + Dec(BytesPerRow); + end; + end; + 3: begin // average filter + // first handle BPP virtual pixels to the left + Raw:=Line; + Decoded:=Line; + Prior:=PrevLine; + TargetRun:=Target; + for I:=0 to pred(BPP) do + begin + TargetRun^:=Byte(Raw^+Floor(Prior^/2)); + Inc(Raw); + Inc(Prior); + Inc(TargetRun); + end; + Dec(BytesPerRow,BPP); + // now do rest of line + while BytesPerRow>0 do + begin + TargetRun^:=Byte(Raw^+Floor((Decoded^+Prior^)/2)); + Inc(Raw); + Inc(Decoded); + Inc(Prior); + Inc(TargetRun); + Dec(BytesPerRow); + end; + end; + 4: begin // paeth prediction + // again, start with first BPP pixel which would refer to non-existing pixels to the left + Raw:=Line; + Decoded:=Target; + Prior:=PrevLine; + PriorDecoded:=PrevLine; + TargetRun:=Target; + for I:=0 to pred(BPP) do + begin + TargetRun^:=Byte(Raw^+PaethPredictor(0,Prior^,0)); + Inc(Raw); + Inc(Prior); + Inc(TargetRun); + end; + Dec(BytesPerRow,BPP); + // finally do rest of line + while BytesPerRow>0 do + begin + TargetRun^:=Byte(Raw^+PaethPredictor(Decoded^,Prior^,PriorDecoded^)); + Inc(Raw); + Inc(Decoded); + Inc(Prior); + Inc(PriorDecoded); + Inc(TargetRun); + Dec(BytesPerRow); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPNGGraphic.LoadFromStream(Stream: PStream); +var Description: TIHDRChunk; +begin + // free previous image + if Assigned(FBitmap) then FBitmap.Free; + FBasePosition:=Stream.Position; + FDecoder:=nil; + FStream:=Stream; + if ReadImageProperties(Stream,0) then + begin + with FImageProperties do + begin + FBitmap:=NewBitmap(Width,Height); + Stream.Position:=FBasePosition+8; // skip magic + FBackgroundColor:=clWhite; + FTransparentColor:=clNone; + // first chunk must be an IHDR chunk + FCurrentCRC:=LoadAndSwapHeader; + FRawBuffer:=nil; + ColorManager.SourceOptions:=[coNeedByteSwap]; + try + // read IHDR chunk + ReadDataAndCheckCRC; + Move(FRawBuffer^,Description,sizeof(Description)); + SwapLong(@Description,2); + // currently only one compression type is supported by PNG (LZ77) + if Compression=ctLZ77 then + begin + FDecoder:=TLZ77Decoder.Create(Z_PARTIAL_FLUSH,False); + FDecoder.DecodeInit; + end + else + GraphicExError(5{gesUnsupportedFeature},[ErrorMsg[11]{gesCompressionScheme},PNG]); + // setup is done, now go for the chunks + repeat + FCurrentCRC:=LoadAndSwapHeader; + if IsChunk(IDAT) then + begin + LoadIDAT(Description); + // After reading the image data the next chunk header has already been loaded + // so continue with code below instead trying to load a new chunk header. + end + else + if IsChunk(PLTE) then + begin + // palette chunk + if (FHeader.Length mod 3)<>0 then GraphicExError(9{gesInvalidPalette},[PNG]); + ReadDataAndCheckCRC; + // load palette only if the image is indexed colors + if Description.ColorType=3 then + begin + // first setup pixel format before actually creating a palette + FSourceBPP:=SetupColorDepth(Description.ColorType,Description.BitDepth); + ColorManager.CreateColorPalette(FBitmap,[FRawBuffer],pfInterlaced8Triple,FHeader.Length div 3,True); + end; + Continue; + end + else + if IsChunk(gAMA) then + begin + ReadDataAndCheckCRC; + // the file gamme given here is a scaled cardinal (e.g. 0.45 is expressed as 45000) + ColorManager.SetGamma(SwapLong(PCardinal(FRawBuffer)^)/100000); + ColorManager.TargetOptions:=ColorManager.TargetOptions+[coApplyGamma]; + Include(Options,ioUseGamma); + Continue; + end + else + if IsChunk(bKGD) then + begin + LoadBackgroundColor(Description); + Continue; + end + else + if IsChunk(tRNS) then + begin + LoadTransparency(Description); + Continue; + end; + // Skip unknown or unsupported chunks (+4 because of always present CRC). + // IEND will be skipped as well, but this chunk is empty, so the stream will correctly + // end on the first byte after the IEND chunk. + Stream.Seek(FHeader.Length+4,spCurrent); + if IsChunk(IEND) then Break; + // Note: According to the specs an unknown, but as critical marked chunk is a fatal error. + if (Byte(FHeader.ChunkType[0]) and CHUNKMASK)=0 then GraphicExError(10{gesUnknownCriticalChunk}); + until False; + finally + if Assigned(FDecoder) then + begin + FDecoder.DecodeEnd; + FDecoder.Free; + end; + if Assigned(FRawBuffer) then FreeMem(FRawBuffer); + end; + end; + end + else GraphicExError(1{gesInvalidImage},[PNG]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPNGGraphic.ReadImageProperties(Stream: PStream; ImageIndex: cardinal): boolean; +var Magic: array[0..7] of byte; + Description: TIHDRChunk; +begin + Result:=inherited ReadImageProperties(Stream,ImageIndex); + FStream:=Stream; + with FImageProperties do + begin + Stream.Read(Magic,8); + if CompareMem(@Magic,@PNGMagic,8) then + begin + // first chunk must be an IHDR chunk + FCurrentCRC:=LoadAndSwapHeader; + if IsChunk(IHDR) then + begin + Include(Options,ioBigEndian); + // read IHDR chunk + ReadDataAndCheckCRC; + Move(FRawBuffer^,Description,sizeof(Description)); + SwapLong(@Description,2); + if (Description.Width=0) or (Description.Height=0) then Exit; + Width:=Description.Width; + Height:=Description.Height; + if Description.Compression=0 then Compression:=ctLZ77 else Compression:=ctUnknown; + BitsPerSample:=Description.BitDepth; + SamplesPerPixel:=1; + case Description.ColorType of + 0: ColorScheme:=csG; + 2: begin + ColorScheme:=csRGB; + SamplesPerPixel:=3; + end; + 3: ColorScheme:=csIndexed; + 4: ColorScheme:=csGA; + 6: begin + ColorScheme:=csRGBA; + SamplesPerPixel:=4; + end; + else ColorScheme:=csUnknown; + end; + BitsPerPixel:=SamplesPerPixel*BitsPerSample; + FilterMode:=Description.Filter; + Interlaced:=Description.Interlaced<>0; + HasAlpha:=ColorScheme in [csGA,csRGBA,csBGRA]; + // find gamma + repeat + FCurrentCRC:=LoadAndSwapHeader; + if IsChunk(gAMA) then + begin + ReadDataAndCheckCRC; + // the file gamme given here is a scaled cardinal (e.g. 0.45 is expressed as 45000) + FileGamma:=SwapLong(PCardinal(FRawBuffer)^)/100000; + Break; + end; + Stream.Seek(FHeader.Length+4,spCurrent); + if IsChunk(IEND) then Break; + until False; + Result:=True; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPNGGraphic.LoadBackgroundColor(const Description); +// loads the data from the current chunk (must be a bKGD chunk) and fills the bitmpap with that color +var Run: PWord; + R,G,B: byte; +begin + ReadDataAndCheckCRC; + with TIHDRChunk(Description) do + begin + case ColorType of + 0,4: // G(A) + begin + case BitDepth of + 2: FBackgroundColor:=MulDiv16(System.Swap(PWord(FRawBuffer)^),15,3); + 16: FBackgroundColor:=MulDiv16(System.Swap(PWord(FRawBuffer)^),255,65535); + else // 1,4,8 bits gray scale + FBackgroundColor:=Byte(System.Swap(PWord(FRawBuffer)^)); + end; + end; + 2,6: // RGB(A) + begin + Run:=FRawBuffer; + if BitDepth=16 then + begin + R:=MulDiv16(System.Swap(Run^),255,65535); + Inc(Run); + G:=MulDiv16(System.Swap(Run^),255,65535); + Inc(Run); + B:=MulDiv16(System.Swap(Run^),255,65535); + end + else + begin + R:=Byte(System.Swap(Run^)); + Inc(Run); + G:=Byte(System.Swap(Run^)); + Inc(Run); + B:=Byte(System.Swap(Run^)); + end; + FBackgroundColor:=Windows.RGB(R,G,B); + end; + else // indexed color scheme (3) + FBackgroundColor:=PByte(FRawBuffer)^; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPNGGraphic.LoadIDAT(const Description); +// loads image data from the current position of the stream +const + // interlace start and offsets + RowStart: array[0..6] of integer = (0,0,4,0,2,0,1); + ColumnStart: array[0..6] of integer = (0,4,0,2,0,1,0); + RowIncrement: array[0..6] of integer = (8,8,8,4,4,2,2); + ColumnIncrement: array[0..6] of integer = (8,8,4,4,2,2,1); + PassMask: array[0..6] of byte = ($80,$08,$88,$22,$AA,$55,$FF); +var Row: Integer; + TargetBPP: integer; + RowBuffer: array[Boolean] of PChar; // I use PChar here instead of simple pointer to ease pointer math below + EvenRow: boolean; // distincts between the two rows we need to hold for filtering + Pass,BytesPerRow,InterlaceRowBytes,InterlaceWidth: integer; +begin + RowBuffer[False]:=nil; + RowBuffer[True]:=nil; + try + // we can set the dimensions too without + // initiating color conversions + if FBitmap=nil then FBitmap:=NewBitmap(TIHDRChunk(Description).Width,TIHDRChunk(Description).Height); + // adjust pixel format etc. if not yet done + if FBitmap.PixelFormat=pfDevice then FSourceBPP:=SetupColorDepth(TIHDRChunk(Description).ColorType,TIHDRChunk(Description).BitDepth); + if TIHDRChunk(Description).BitDepth=16 then TargetBPP:=FSourceBPP div 2 else TargetBPP:=FSourceBPP; + // set background and transparency color, these values must be set after the + // bitmap is actually valid (although, not filled) + FBitmap.Canvas.Brush.Color:=FBackgroundColor; + FBitmap.Canvas.FillRect(Rect(0,0,FBitmap.Width,FBitmap.Height)); + // determine maximum number of bytes per row and consider there's one filter byte at the start of each row + BytesPerRow:=TargetBPP*((FBitmap.Width*TIHDRChunk(Description).BitDepth+7) div 8)+1; + RowBuffer[True]:=AllocMem(BytesPerRow); + RowBuffer[False]:=AllocMem(BytesPerRow); + // there can be more than one IDAT chunk in the file but then they must directly + // follow each other (handled in ReadRow) + EvenRow:=True; + // prepare interlaced images + if TIHDRChunk(Description).Interlaced=1 then + begin + for Pass:=0 to 6 do + begin + // prepare next interlace run + if FBitmap.Width<=ColumnStart[Pass] then Continue; + InterlaceWidth:=(FBitmap.Width+ColumnIncrement[Pass]-1-ColumnStart[Pass]) div ColumnIncrement[Pass]; + InterlaceRowBytes:=TargetBPP*((InterlaceWidth*TIHDRChunk(Description).BitDepth+7) div 8)+1; + Row:=RowStart[Pass]; + while RowFileCRC then GraphicExError(6{gesInvalidCRC},[PNG]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TPNGGraphic.ReadRow(RowBuffer: pointer; BytesPerRow: integer); +// reads and decodes one scanline +var LocalBuffer: pointer; + PendingOutput: integer; +begin + LocalBuffer:=RowBuffer; + PendingOutput:=BytesPerRow; + repeat + // read pending chunk data if available input has dropped to zero + if FDecoder.AvailableInput=0 then + begin + FIDATSize:=0; + // read all following chunks until enough data is available or there is no further IDAT chunk + while FIDATSize=0 do + begin + // finish if the current chunk is not an IDAT chunk + if not IsChunk(IDAT) then Exit; + ReadDataAndCheckCRC; + FCurrentSource:=FRawBuffer; + FIDATSize:=FHeader.Length; + // prepare next chunk (plus CRC) + FCurrentCRC:=LoadAndSwapHeader; + end; + end; + // this decode call will advance Source and Target accordingly + FDecoder.Decode(FCurrentSource,LocalBuffer, + FIDATSize-(Integer(FCurrentSource)-Integer(FRawBuffer)), + PendingOutput); + if FDecoder.ZLibResult=Z_STREAM_END then + begin + if (FDecoder.AvailableOutput<>0) or (FDecoder.AvailableInput<>0) then GraphicExError(8{gesExtraCompressedData},[PNG]); + Break; + end; + if FDecoder.ZLibResult<>Z_OK then GraphicExError(7{gesCompression},[PNG]); + PendingOutput:=BytesPerRow-(Integer(LocalBuffer)-Integer(RowBuffer)); + until PendingOutput=0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TPNGGraphic.SetupColorDepth(ColorType,BitDepth: integer): integer; +begin + Result:=0; + // determine color scheme and setup related stuff, + // Note: The calculated BPP value is always at least 1 even for 1 bits per pixel etc. formats + // and used in filter calculation. + case ColorType of + 0: // gray scale (allowed bit depths are: 1, 2, 4, 8, 16 bits) + if BitDepth in [1,2,4,8,16] then + begin + ColorManager.SourceColorScheme:=csG; + ColorManager.TargetColorScheme:=csG; + ColorManager.SourceSamplesPerPixel:=1; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.SourceBitsPerSample:=BitDepth; + // 2 bits values are converted to 4 bits values because DIBs don't know the former variant + case BitDepth of + 2: ColorManager.TargetBitsPerSample:=4; + 16: ColorManager.TargetBitsPerSample:=8; + else + ColorManager.TargetBitsPerSample:=BitDepth; + end; + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + ColorManager.CreateGrayscalePalette(FBitmap,False); + Result:=(BitDepth+7) div 8; + end + else GraphicExError(2{gesInvalidColorFormat},[PNG]); + 2: // RGB + if BitDepth in [8,16] then + begin + ColorManager.SourceSamplesPerPixel:=3; + ColorManager.TargetSamplesPerPixel:=3; + ColorManager.SourceColorScheme:=csRGB; + ColorManager.TargetColorScheme:=csBGR; + ColorManager.SourceBitsPerSample:=BitDepth; + ColorManager.TargetBitsPerSample:=8; + FBitmap.PixelFormat:=pf24Bit; + Result:=BitDepth*3 div 8; + end + else GraphicExError(2{gesInvalidColorFormat},[PNG]); + 3: // palette + if BitDepth in [1,2,4,8] then + begin + ColorManager.SourceColorScheme:=csIndexed; + ColorManager.TargetColorScheme:=csIndexed; + ColorManager.SourceSamplesPerPixel:=1; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.SourceBitsPerSample:=BitDepth; + // 2 bits values are converted to 4 bits values because DIBs don't know the former variant + if BitDepth=2 then ColorManager.TargetBitsPerSample:=4 else ColorManager.TargetBitsPerSample:=BitDepth; + FBitmap.PixelFormat:=ColorManager.TargetPixelFormat; + Result:=1; + end + else GraphicExError(2{gesInvalidColorFormat},[PNG]); + 4: // gray scale with alpha, + // For the moment this format is handled without alpha, but might later be converted + // to RGBA with gray pixels or use a totally different approach. + if BitDepth in [8,16] then + begin + ColorManager.SourceSamplesPerPixel:=1; + ColorManager.TargetSamplesPerPixel:=1; + ColorManager.SourceBitsPerSample:=BitDepth; + ColorManager.TargetBitsPerSample:=8; + ColorManager.SourceColorScheme:=csGA; + ColorManager.TargetColorScheme:=csIndexed; + FBitmap.PixelFormat:=pf8Bit; + ColorManager.CreateGrayScalePalette(FBitmap,False); + Result:=2*BitDepth div 8; + end + else GraphicExError(2{gesInvalidColorFormat},[PNG]); + 6: // RGB with alpha (8, 16) + if BitDepth in [8,16] then + begin + ColorManager.SourceSamplesPerPixel:=4; + ColorManager.TargetSamplesPerPixel:=4; + ColorManager.SourceColorScheme:=csRGBA; + ColorManager.TargetColorScheme:=csBGRA; + ColorManager.SourceBitsPerSample:=BitDepth; + ColorManager.TargetBitsPerSample:=8; + FBitmap.PixelFormat:=pf32Bit; + Result:=BitDepth*4 div 8; + end + else GraphicExError(2{gesInvalidColorFormat},[PNG]); + else + GraphicExError(2{gesInvalidColorFormat},[PNG]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. + diff --git a/Addons/KOLHTTPDownload.pas b/Addons/KOLHTTPDownload.pas new file mode 100644 index 0000000..dae4a7f --- /dev/null +++ b/Addons/KOLHTTPDownload.pas @@ -0,0 +1,1138 @@ +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} +unit KOLHTTPDownload; +{ + + ("`-''-/").___..--''"`-._ + `6_ 6 ) `-. ( ).`-.__.`) + (_Y_.)' ._ ) `._ `. ``-..-' + _..`--'_..-_/ /--'_.' ,' +(il).-'' (li).' ((!.-' + + Download with HTTP-protocol + + Copyright © 2007-2008 Denis Fateyev (Danger) + Website: + E-Mail: + + 'ParseURL' and 'Posn' functions are copyright (C) 1997-2001 by Francois Piette + "Permission is granted to anyone to use this software for any purpose, including + commercial applications, and to alter it and redistribute it freely." } + + {* TKOLHTTPDownload is the non-visual component that provides a downloading resources with HTTP-protocol. Now uses WinInet routines. + |
+  |Copyright (C) 2007-2008 Denis Fateyev (Danger) (denis@fateyev.com).
+  |
+ |TKOLHTTPDownload coming under the form of a KOL library unit, it can be simply used + by creating object at runtime, setting the necessary properties: + !uses Windows, Messages, KOL, ..., KOLHTTPDownload; + ! //... + !var DL : PHTTPDownload; + ! //... + !DL := NewHTTPDownload; + !DL.OnDownload:= MyDownload_Proc; + !DL.GetResource( 'http://example.com/foo/bar.zip' ); + !DL. ... + !DL.Free; + |

Certainly you can use the 'MCK mirror' provided with component to manage control properties at design time. } + +interface + +// This conditional define allows some manupulations with HTTP-headers, +// you can disable it (if you really don't need it) by commenting the following line. +{$DEFINE USE_CUSTOMHEADERS} + +//----------------------------------------------------- +uses + Windows, WinInet, KOL; + +//----------------------------------------------------- +const + iDefProxyPort = 3128; + iTimeOutValue = 200; // 0.2 sec + iDataBufSize = 4096; // 4 KByte buffer + strUserAgent = 'Dangers HTTPClient/2.1'; + strConnectType = 'Connection: close'; + strProxyConnectType = 'Proxy-Connection: close'; + +//----------------------------------------------------- + { THTTPHeader } + +type + PHTTPHeader = ^THTTPHeader; + THTTPHeader = record + {* |

Most important values that can be extracted from http-servers response + |(see ParseHeaders procedure + |below for more details).

} + HTTPVersion: KOLstring; + StatusCode: Integer; + ReasonPhrase: KOLstring; + ServerDate: KOLstring; + ServerStr: KOLstring; + LastModified: KOLstring; + Location: KOLstring; + SetCookie: KOLstring; + Expires: KOLstring; + ContentLength: Integer; + TransferEncoding: KOLstring; + ContentType: KOLstring; + end; + +//----------------------------------------------------- + { THTTPDownload } + + PHTTPDownload = ^THTTPDownload; + PDownloadWorker = ^TDownloadWorker; + TKOLHTTPDownload = PHTTPDownload; + THTTPHdrRecvEvent = procedure( Sender: PHTTPDownload; HeaderList: PStrList ) of object; + {* |Event to be called when http-headers received from http-server. } + + THTTPProgressEvent = procedure( Sender: PHTTPDownload; + BytesRecv: Integer; BytesAll: Integer ) of object; + {* |Event to be called when download progress is changed. } + + THTTPErrorEvent = procedure( Sender: PHTTPDownload; Error: Word ) of object; + {* |Event to be called when error occured while download process. } + + THTTPDownloadEvent = procedure( Sender: PHTTPDownload; Data: PStream ) of object; + {* |Event to be called when resource download completed. } + + THTTPDownload = object( TObj ) + {* |This object implements all functionality of component.
+ |Use NewHTTPDownload constuction function for creation of object instance. Here is the prototype: + ! function NewHTTPDownload: PHTTPDownload; } + private + fWorker: PDownloadWorker; + fHeaderList: PStrList; + {$IFDEF USE_CUSTOMHEADERS} + fCHeaderList: PStrList; + {$ENDIF} + fDataStream: PStream; + fResource: string; + fBusy: Boolean; + fPort: Word; + fHostName: string; + fPath: string; + fUserName: string; + fPassword: string; + fProxySrv: string; + fProxyPort: Word; + fPreConfigProxy: Boolean; + + fOnError: THTTPErrorEvent; + fOnHeaderReceived: THTTPHdrRecvEvent; + fOnProgress: THTTPProgressEvent; + fOnDownload: THTTPDownloadEvent; + + public + function CheckConnection( AResourceName: string ): Boolean; + {* Simple check if a connection to host that provides specified resource can be established, + and requested resource can be retrieved. By example: + ! CheckConnection( 'http://www.example.com/foo/bar.zip' ); + Note that this function may give the wrong results if destination host doesn't accept 'ping' requests. + |Return value: True if a connection is made successfully, or False otherwise. } + + function GetResource( AResourceName: string ): Boolean; + {* |Initiate download process for the specified resource.
+ |The parameter AResourceName must contains full path of the requested resource + in such syntax: + ! protocol://[user[:password]@]server[:port]/path + |If parameter port not specified, then standard http-port (80) will be used in request. + Authorization parameters can be omitted too, if isn't needed. + In simple case can be used, by example: + ! GetResource( 'http://www.example.com/foo/bar.zip' ); + |Return value: the function returns False if resource request has invalid syntax, + |otherwise True returned. } + + procedure SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); + {* |Proxy settings for the resource request.
+ |iProxyPort parameter can be omitted then standard proxy port (3128) will be used. } + + procedure SetAuthInfo( AUserName: string; APassword: string ); + {* Authorization parameters for the resource request. } + + function ParseHeaders( var Header: PHTTPHeader ): Boolean; + {* Extract http-headers information and put into the specified HTTPHeader. By example: + !var + ! DL: PHTTPDownload; + ! Header: PHTTPHeader; + !// ... + !procedure TForm1.DLHeaderReceived( Sender: PHTTPDownload; HeaderList: PStrList ); + !begin + ! New( Header ); + ! DL.ParseHeaders( Header ); + ! // ... do something with Header ... + ! MsgOk( Header.ReasonPhrase ); + ! // ... + ! Dispose( Header ); + !end; + |Return value: False if http-headers doesn't exists (nothing to analyze). } + + {$IFDEF USE_CUSTOMHEADERS} + procedure AddCustomHeader( AHeader: string ); + {* |Add custom line to requests http-header. By example: + !var + ! DL: PHTTPDownload; + !// ... + !procedure TForm1.Button1Click( Sender: PObj ); + !begin + ! DL.AddCustomHeader( 'Cookie: PHPSESSID=abcdef' ); + ! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); + !end; + Once assigned these headers will be added automatically to each request sent to http-server + (while the current THTTPDownload object is in use). Custom headers are not assigned by default. + |To clear user defined http-headers list, call ClearCustomHeaders procedure. + |Note that 'Connection: close' or 'Proxy-Connection: close' (depends on connection type) + |will be included in the request headers anyway.
+ |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } + + procedure SetCustomHeaders( AHeaderList: PStrList ); + {* |Assign the custom http-headers list from another one. By example: + !var + ! DL: PHTTPDownload; + ! CList: PStrList; + !// ... + !procedure TForm1.Button1Click( Sender: PObj ); + !begin + ! CList:= NewStrList; + ! CList.Add( 'Cookie: PHPSESSID=abcdef' ); + ! DL.SetCustomHeaders( CList ); + ! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); + ! CList.Free; + !end; + |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } + + procedure ClearCustomHeaders; + {* |Clear user defined http-headers list (restore to defaults). + |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } + {$ENDIF} + + procedure CancelDownload; + {* |Drop current download process immediately. } + + property Resource: string read fResource; + {* |Currently requested resource. By default: None. } + + property ProxyServer: string read fProxySrv write fProxySrv; + {* |IP-address or hostname of http-proxy server. By default: None. } + + property ProxyPort: Word read fProxyPort write fProxyPort; + {* |TCP Port of http-proxy server. By default: 3128. } + + property UserName: string read fUserName write fUserName; + {* |HTTP Autorization parameters: username. By default: None. } + + property Password: string read fPassword write fPassword; + {* |HTTP Autorization parameters: password. By default: None. } + + property UsePreconfigProxy: Boolean read fPreConfigProxy write fPreConfigProxy; + {*|Parameter that allows to use connection settings stored in Internet Explorer. + Retrieves the proxy or direct configuration from the Windows registry. + |By default: False. } + + property HeaderList: PStrList read fHeaderList; + {*|Retrieves all received http-headers in raw format (as is). + Most important parameters can be retrieved with ParseHeaders procedure. } + + {$IFDEF USE_CUSTOMHEADERS} + property CustomHeaderList: PStrList read fCHeaderList; + {*|Retrieves custom http-header list assigned by user. + See SetCustomHeaders procedure for more details. } + {$ENDIF} + + property ReceivedData: PStream read fDataStream; + {*|Retrieves downloaded resource if present. } + + property Busy: Boolean read fBusy; + {*| If True, the object is busy and resource download is in progress at the moment. + If you wish, you can terminate download process at any moment with CancelDownload procedure. } + + property OnError: THTTPErrorEvent read fOnError write fOnError; + {* |Event to be called when error occured while download process. } + + property OnHeaderReceived: THTTPHdrRecvEvent read fOnHeaderReceived write fOnHeaderReceived; + {* |Event to be called when http-headers received from http-server. } + + property OnProgress: THTTPProgressEvent read fOnProgress write fOnProgress; + {* |Event to be called when download progress is changed. + Note that there's no way to automatically determine the whole size of requested resource + |if 'Content-Length' field is missing in the http-header (i.e. if Transfer-Encoding + |header field (rfc-2068 section 14.40) is present and indicates that the "chunked" transfer + |coding has been applied). Therefore, if 'Content-Length' is present, BytesAll + |parameter indicates the requested resource size, otherwise it's equal to '-1'. } + + property OnDownload: THTTPDownloadEvent read fOnDownload write fOnDownload; + {* |Event to be called when resource download completed. } + + destructor Destroy; virtual; + end; + +//----------------------------------------------------- + { TDownloadWorker } + + TDownloadWorker = object (TObj ) + private + // Contains parent object's pointer (or NIL if download terminated) + fOwner: PHTTPDownload; + fWThread: PThread; + fDLThread: PThread; + fCritSection: TRTLCriticalSection; + fDataBuf: PChar; + fPort: Word; + fHostName: string; + fPath: string; + fUserName: string; + fPassword: string; + fProxySrv: string; + fProxyPort: Word; + fPreConfigProxy: Boolean; + iContentLen: Integer; + iReadCount: Integer; + + function On_DownloadExecute( Sender: PThread ): Integer; + function On_WatchExecute( Sender: PThread ): Integer; + procedure On_UpdateProgress; + + public + procedure StartDownload; + function StopDownload: Integer; + destructor Destroy; virtual; + end; + +//----------------------------------------------------- +function NewHTTPDownload: PHTTPDownload; +function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; +//----------------------------------------------------- + +implementation + +//----------------------------------------------------- +function NewHTTPDownload: PHTTPDownload; +begin + New( Result, Create ); + with ( Result^ ) do + begin + fBusy:= false; + fPreConfigProxy:= false; + fProxyPort:= iDefProxyPort; + end; +end; + +//----------------------------------------------------- +function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; +begin + New( Result, Create ); + with ( Result^ ) do + begin + fOwner:= AOwner; + InitializeCriticalSection( fCritSection ); + end; +end; + +//----------------------------------------------------- +function StrPas(const Str: PChar): string; +begin + Result:= Str; +end; + +//----------------------------------------------------- +{ Find the count'th occurence of the s string in the t string. } +{ If count < 0 then look from the back } +function Posn(const s , t : String; Count : Integer) : Integer; +var + i, h, Last : Integer; + u : String; +begin + u := t; + if Count > 0 then + begin + Result := Length(t); + for i := 1 to Count do + begin + h := Pos(s, u); + if h > 0 then + u := Copy(u, h + 1, Length(u)) + else + begin + u := ''; + Inc(Result); + end; + end; + Result := Result - Length(u); + end + else if Count < 0 then + begin + Last := 0; + for i := Length(t) downto 1 do + begin + u := Copy(t, i, Length(t)); + h := Pos(s, u); + if (h <> 0) and ((h + i) <> Last) then + begin + Last := h + i - 1; + Inc(count); + if Count = 0 then + break; + end; + end; + if Count = 0 then + Result := Last + else + Result := 0; + end + else + Result := 0; +end; + +//----------------------------------------------------- +{ Syntax of an URL: protocol://[user[:password]@]server[:port]/path } +procedure ParseURL(const url : String; var Proto, User, Pass, Host, Port, Path : String); +var + p, q : Integer; + s : String; + CurPath : String; +begin + CurPath := Path; + proto := ''; + User := ''; + Pass := ''; + Host := ''; + Port := ''; + Path := ''; + + if Length(url) < 1 then Exit; + + { Handle path beginning with "./" or "../". } + { This code handle only simple cases ! } + { Handle path relative to current document directory } + if (Copy(url, 1, 2) = './') then + begin + p := Posn('/', CurPath, -1); + if p > Length(CurPath) then + p := 0; + if p = 0 then + CurPath := '/' + else + CurPath := Copy(CurPath, 1, p); + Path := CurPath + Copy(url, 3, Length(url)); + Exit; + end + { Handle path relative to current document parent directory } + else if (Copy(url, 1, 3) = '../') then + begin + p := Posn('/', CurPath, -1); + if p > Length(CurPath) then + p := 0; + if p = 0 then + CurPath := '/' + else + CurPath := Copy(CurPath, 1, p); + + s := Copy(url, 4, Length(url)); + { We could have several levels } + while TRUE do + begin + CurPath := Copy(CurPath, 1, p-1); + p := Posn('/', CurPath, -1); + if p > Length(CurPath) then + p := 0; + if p = 0 then + CurPath := '/' + else + CurPath := Copy(CurPath, 1, p); + if (Copy(s, 1, 3) <> '../') then + break; + s := Copy(s, 4, Length(s)); + end; + + Path := CurPath + Copy(s, 1, Length(s)); + Exit; + end; + + p := pos('://',url); + if p = 0 then + begin + if (url[1] = '/') then + begin + { Relative path without protocol specified } + proto := 'http'; + p := 1; + if (Length(url) > 1) and (url[2] <> '/') then + begin + { Relative path } + Path := Copy(url, 1, Length(url)); + Exit; + end; + end + else if lowercase(Copy(url, 1, 5)) = 'http:' then + begin + proto := 'http'; + p := 6; + if (Length(url) > 6) and (url[7] <> '/') then + begin + { Relative path } + Path := Copy(url, 6, Length(url)); + Exit; + end; + end + else if lowercase(Copy(url, 1, 7)) = 'mailto:' then + begin + proto := 'mailto'; + p := pos(':', url); + end; + end + else + begin + proto := Copy(url, 1, p - 1); + inc(p, 2); + end; + s := Copy(url, p + 1, Length(url)); + + p := pos('/', s); + q := pos('?', s); + if (q > 0) and ((q < p) or (p = 0)) then + p := q; + if p = 0 then + p := Length(s) + 1; + Path := Copy(s, p, Length(s)); + s := Copy(s, 1, p-1); + + p := Posn(':', s, -1); + if p > Length(s) then + p := 0; + q := Posn('@', s, -1); + if q > Length(s) then + q := 0; + if (p = 0) and (q = 0) then + begin { no user, password or port } + Host := s; + Exit; + end + else if q < p then + begin { a port given } + Port := Copy(s, p + 1, Length(s)); + Host := Copy(s, q + 1, p - q - 1); + if q = 0 then + Exit; { no user, password } + s := Copy(s, 1, q - 1); + end + else + begin + Host := Copy(s, q + 1, Length(s)); + s := Copy(s, 1, q - 1); + end; + p := pos(':', s); + if p = 0 then + User := s + else + begin + User := Copy(s, 1, p - 1); + Pass := Copy(s, p + 1, Length(s)); + end; +end; + +//---------------- { THTTPDownload } ------------------------------- + +function THTTPDownload.ParseHeaders( var Header: PHTTPHeader ): Boolean; +var + i: Integer; S: KOLstring; +begin + Result:= false; + + if ( not Assigned( fHeaderList ) ) then Exit; + // HTTP/1.1 200 OK + Header.ReasonPhrase:= fHeaderList.Items[0]; + Header.HTTPVersion:= Parse( Header.ReasonPhrase, ' ' ); + Header.StatusCode:= Str2Int( Parse(Header.ReasonPhrase, ' ') ); + // avoid curious things if value isn't present in the list + Header.ContentLength:= -1; + // begin from second list item + for i:= 2 to fHeaderList.Count do + begin + S:= fHeaderList.Items[i-1]; + // Date: Wed, 09 May 2007 14:31:23 GMT + if ( Pos('Date: ', S) > 0 ) then + begin + Parse(S, ' '); Header.ServerDate:= S; + Continue; + end; + // Server: Apache x.x.x (Unix) + if ( Pos('Server: ', S) > 0 ) then + begin + Parse(S, ' '); Header.ServerStr:= S; + Continue; + end; + // Last-Modified: Wed, 09 May 2007 14:31:23 GMT + if ( Pos('Last-Modified: ', S) > 0 ) then + begin + Parse(S, ' '); Header.LastModified:= S; + Continue; + end; + // Set-Cookie: PHPSESSID=xxxxxxxxx + if ( Pos('Set-Cookie: ', S) > 0 ) then + begin + Parse(S, ' '); Header.SetCookie:= S; + Continue; + end; + // Expires: Wed, 10 May 2007 14:31:23 GMT + if ( Pos('Expires: ', S) > 0 ) then + begin + Parse(S, ' '); Header.Expires:= S; + Continue; + end; + // Location: foobar.html + if ( Pos('Location: ', S) > 0 ) then + begin + Parse(S, ' '); Header.Location:= S; + Continue; + end; + // Content-Length: 12345 + if ( Pos('Content-Length: ', S) > 0 ) then + begin + Parse(S, ' '); Header.ContentLength:= Str2Int( S ); + Continue; + end; + // Transfer-Encoding: chunked + if ( Pos('Transfer-Encoding: ', S) > 0 ) then + begin + Parse(S, ' '); Header.TransferEncoding:= S; + Continue; + end; + // Content-Type: application/zip + if ( Pos('Content-Type: ', S) > 0 ) then + begin + Parse(S, ' '); Header.ContentType:= S; + Continue; + end; + end; + + Result:= true; +end; + +//----------------------------------------------------- +procedure THTTPDownload.SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); +begin + fProxySrv:= AProxyServer; + fProxyPort:= iProxyPort; +end; + +//----------------------------------------------------- +procedure THTTPDownload.SetAuthInfo( AUserName: string; APassword: string ); +begin + fUserName:= AUserName; + fPassword:= APassword; +end; + +//----------------------------------------------------- +{$IFDEF USE_CUSTOMHEADERS} +procedure THTTPDownload.AddCustomHeader( AHeader: string ); +begin + if ( Length( AHeader ) > 0 ) then + begin + if ( not Assigned( fCHeaderList ) ) then + begin + fCHeaderList:= NewStrList; + fCHeaderList.Add2AutoFree( @Self ); + end; // 'if ( not Assigned( fCHeaderList )' + fCHeaderList.Add( AHeader ); + end; +end; + +//----------------------------------------------------- +procedure THTTPDownload.ClearCustomHeaders; +begin + if Assigned( fCHeaderList ) then fCHeaderList.Clear; +end; + +//----------------------------------------------------- +procedure THTTPDownload.SetCustomHeaders( AHeaderList: PStrList ); +begin + if Assigned( AHeaderList ) then + begin + if ( not Assigned( fCHeaderList ) ) then + begin + fCHeaderList:= NewStrList; + fCHeaderList.Add2AutoFree( @Self ); + end; // 'if ( not Assigned( fCHeaderList )' + fCHeaderList.Assign( AHeaderList ); + end; +end; +{$ENDIF} + +//----------------------------------------------------- +function THTTPDownload.CheckConnection( AResourceName: string ): Boolean; +begin + Result:= false; + + // I'm wondering why FLAG_ICC_FORCE_CONNECTION declaration is missing in WinInet.pas + if ( InternetCheckConnection( PChar( AResourceName ), $00000001 {FLAG_ICC_FORCE_CONNECTION}, 0 ) ) then + Result:= true + else + if Assigned( fOnError ) then fOnError( @Self, GetLastError ); +end; + +//----------------------------------------------------- +function THTTPDownload.GetResource( AResourceName: string ): Boolean; +var + strPort, strProto: string; +begin + Result:= false; + CancelDownload; + + if ( not fBusy ) then + begin + fResource:= AResourceName; + // checking request data + ParseURL( fResource, strProto, fUserName, fPassword, fHostName, strPort, fPath ); + if ( strProto = '' ) then strProto:= 'http'; + if ( ( fHostName = '' ) or ( fPath = '' ) or ( strProto <> 'http' ) ) then + begin + if Assigned( fOnError ) then fOnError( @Self, ERROR_INTERNET_INVALID_URL ); + Exit; + end; + if ( strPort = '' ) then fPort:= INTERNET_DEFAULT_HTTP_PORT + else fPort:= Str2Int( strPort ); + + if Assigned( fOnHeaderReceived ) then + if ( not Assigned( fHeaderList ) ) then + begin + fHeaderList:= NewStrList; + fHeaderList.Add2AutoFree( @Self ); + end; + + if Assigned( fOnDownload ) then + begin + if ( not Assigned( fDataStream ) ) then + begin + fDataStream:= NewMemoryStream; + fDataStream.Add2AutoFree( @Self ); + end + else fDataStream.Size:= 0; + end; + + fBusy:= true; + fWorker:= NewDownloadWorker( @Self ); + fWorker.StartDownload; + Result:= true; + end; + +end; + +//----------------------------------------------------- +procedure THTTPDownload.CancelDownload; +begin + if ( fBusy ) then + fWorker.StopDownload; +end; + +//----------------------------------------------------- +destructor THTTPDownload.Destroy; +begin + CancelDownload; + fResource:= ''; + fHostName:= ''; + fPath:= ''; + fProxySrv:= ''; + fUserName:= ''; + fPassword:= ''; + inherited; +end; + +//---------------- { TDownloadWorker } ------------------------------- + +procedure TDownloadWorker.StartDownload; +begin + fWThread:= NewThread; + fWThread.OnExecute:= On_WatchExecute; + fWThread.Add2AutoFree( @Self ); + fWThread.Resume; +end; + +//----------------------------------------------------- +function TDownloadWorker.On_WatchExecute( Sender: PThread ): Integer; +begin + Result:= 0; // stub + + // create download working thread + fDLThread:= NewThreadEx( On_DownloadExecute ); + // wait for download thread finished (any way) + fDLThread.WaitFor; + // destroy worker object + Free; +end; + +//----------------------------------------------------- +function TDownloadWorker.StopDownload: Integer; +var + lpOwner: PHTTPDownload; +begin + Result:= 0; // stub + + lpOwner:= nil; // avoid compiler warning + EnterCriticalSection( fCritSection ); + try + if Assigned( fOwner ) then + begin + lpOwner:= PHTTPDownload( fOwner ); + fOwner:= nil; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // trying to terminate thread gracefully + if ( not fDLThread.Terminated ) then fDLThread.WaitForTime( iTimeOutValue ); + // terminate thread forcefully + if ( not fDLThread.Terminated ) then fDLThread.Terminate; + + if Assigned( lpOwner ) then + begin + // don't keep partially downloaded file + if Assigned( lpOwner.fDataStream ) then + lpOwner.fDataStream.Size:= 0; + lpOwner.fBusy:= false; + end; + +end; + +//----------------------------------------------------- +procedure TDownloadWorker.On_UpdateProgress; +begin + if Assigned( fOwner ) then + fOwner.OnProgress( fOwner, iReadCount, iContentLen ); +end; + +//----------------------------------------------------- +function TDownloadWorker.On_DownloadExecute( Sender: PThread ): Integer; +var + hSession, hConnect, hRequest: HINTERNET; + iBufSize, lpdwIndex, iNumRead: Cardinal; + Buf: PChar; i, iErrorCode: Integer; + + procedure CloseHandles; + begin + InternetCloseHandle( hRequest ); + InternetCloseHandle( hConnect ); + InternetCloseHandle( hSession ); + end; + +begin + Result:= 0; // stub + + EnterCriticalSection( fCritSection ); + try + if Assigned( fOwner ) then + begin + fHostName:= fOwner.fHostName; + fPath:= fOwner.fPath; + fPort:= fOwner.fPort; + fUserName:= fOwner.fUserName; + fPassword:= fOwner.fPassword; + fPreConfigProxy:= fOwner.fPreConfigProxy; + if ( not fPreConfigProxy ) then + begin + fProxySrv:= fOwner.fProxySrv; + fProxyPort:= fOwner.fProxyPort; + end; + end // 'if Assigned( fOwner ) then' + else Exit; + finally + LeaveCriticalSection( fCritSection ); + end; + + // initializing Wininet, settings some connection parameters + if ( fPreConfigProxy ) then + hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 ) + else + begin + if ( fProxySrv <> '' ) then + hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_PROXY, + PChar( 'http=' + fProxySrv + ':' + Int2Str( fProxyPort) ), nil, 0 ) + else + hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0 ); + end; + if ( hSession = nil ) then + begin + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + Exit; + end; + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then Exit; + finally + LeaveCriticalSection( fCritSection ); + end; + + // connecting to http-server + hConnect:= InternetConnect( hSession, PChar( fHostName ), fPort, + PChar( fUserName ), PChar( fPassword ), INTERNET_SERVICE_HTTP, 0, 0 ); + if ( hConnect = nil ) then + begin + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + CloseHandles; + Exit; + end; + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // prepare resource request to http-server + // we're prefer HTTP/1.0 version but this parameter can be ignored by Wininet + // see KB258425 (http://support.microsoft.com/kb/258425) for more details. + hRequest:= HttpOpenRequest( hConnect, nil, PChar( fPath ), nil, + nil, nil, INTERNET_FLAG_NO_UI + INTERNET_FLAG_PRAGMA_NOCACHE, 0); + if ( hRequest = nil ) then + begin + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + CloseHandles; + Exit; + end; + // adding custom http headers to request + {$IFDEF USE_CUSTOMHEADERS} + with ( fOwner^ ) do + if Assigned( fCHeaderList ) then + with ( fCHeaderList^ ) do + if ( Count > 0 ) then + for i:= 1 to Count do + HttpAddRequestHeaders( hRequest, PChar( Items[i-1] ), Length( Items[i-1] ), HTTP_ADDREQ_FLAG_ADD ); + {$ENDIF} + // setting http headers 'connection type' field (don't allow persistent connection) + if ( fPreConfigProxy or ( fProxySrv <> '' ) ) then + HttpAddRequestHeaders( hRequest, strProxyConnectType, Length( strProxyConnectType ), HTTP_ADDREQ_FLAG_ADD ) + else + HttpAddRequestHeaders( hRequest, strConnectType, Length( strConnectType ), HTTP_ADDREQ_FLAG_ADD ); + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // send http request to server + if ( not HttpSendRequest( hRequest, nil, 0, nil, 0 ) ) then + begin + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + CloseHandles; + Exit; + end; + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // receiving headers (if event assigned) + if Assigned( fOwner.fOnHeaderReceived ) then + begin + lpdwIndex:= 0; Buf:= nil; + HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ); + // NB: it's ok when 'unsufficient buffer' message received now + iErrorCode:= GetLastError; + + if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER ) then + begin + GetMem( Buf, iBufSize ); + lpdwIndex:= 0; + try + if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ) ) then + with ( fOwner^ ) do + begin + fHeaderList.SetText( Buf, false ); + with ( fHeaderList^ ) do + if ( Items[Count-1] = '' ) then Delete( Count-1 ); + fOnHeaderReceived( fOwner, fHeaderList ); + end // 'if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, iReserved ) )' + else + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + + finally + FreeMem( Buf ); + end; + end // 'if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER )' + else + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, iErrorCode ); + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + end; // 'if Assigned( fOnHeaderReceived )' + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // getting http status code + iBufSize:= 16; + iErrorCode:= 0; + lpdwIndex:= 0; + GetMem( Buf, iBufSize ); + try + if ( HttpQueryInfo( hRequest, HTTP_QUERY_STATUS_CODE, Buf, iBufSize, lpdwIndex ) ) then + iErrorCode:= Str2Int( StrPas( Buf ) ) + else + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); + finally + FreeMem( Buf ); + end; + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // checking if resource is available + if ( ( Assigned( fOwner.fOnDownload ) and ( iErrorCode = HTTP_STATUS_OK {HTTP/1.1 200 OK} ) ) ) then + begin + iBufSize:= 16; + lpdwIndex:= 0; + iContentLen:= 0; + GetMem( Buf, iBufSize ); + try + if ( HttpQueryInfo( hRequest, HTTP_QUERY_CONTENT_LENGTH, Buf, iBufSize, lpdwIndex ) ) then + // getting http content length + iContentLen:= Str2Int( StrPas( Buf ) ); + // set iContentLen value to '-1' if not present or invalid + if ( iContentLen <= 0 ) then iContentLen:= -1; + + iReadCount:= 0; + GetMem( fDataBuf, iDataBufSize ); + try + // downloading resource + with ( fOwner^ ) do + while ( InternetReadFile( hRequest, fDataBuf, iDataBufSize, iNumRead ) ) do + if ( iNumRead > 0 ) then + begin + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then Break; + finally + LeaveCriticalSection( fCritSection ); + end; + + // write received data to stream + fDataStream.Write( fDataBuf^, iNumRead ); + Inc( iReadCount, iNumRead ); + // update download progress + if Assigned( fOnProgress ) then fDLThread.Synchronize( On_UpdateProgress ); + end + // 'if ( iNumRead > 0 )' + else Break; + + // checking if thread must be terminated + EnterCriticalSection( fCritSection ); + try + if ( not Assigned( fOwner ) ) then + begin + CloseHandles; + Exit; + end; + finally + LeaveCriticalSection( fCritSection ); + end; + + // download complete + with ( fOwner^ ) do + begin + fDataStream.Position:= 0; + // call assigned event handler + fOnDownload( @Self, fDataStream ); + end; + + finally + FreeMem( fDataBuf ); + end; + + finally + FreeMem( Buf ); + end; + + end // 'if ( ( Assigned( fOnDownload ) and ( iErrorCode = HTTP_STATUS_OK {HTTP/1.1 200 OK} ) ) )' + else + if ( iErrorCode <> HTTP_STATUS_OK { HTTP/1.1 OK } ) then + with ( fOwner^ ) do + if Assigned( fOnError ) then fOnError( fOwner, ERROR_INTERNET_EXTENDED_ERROR ); + + CloseHandles; +end; + +//----------------------------------------------------- +destructor TDownloadWorker.Destroy; +begin + fDLThread.Free; + fHostName:= ''; + fPath:= ''; + fUserName:= ''; + fPassword:= ''; + fProxySrv:= ''; + EnterCriticalSection( fCritSection ); + try + if Assigned( fOwner ) then + fOwner.fBusy:= false; + finally + LeaveCriticalSection( fCritSection ); + end; + DeleteCriticalSection( fCritSection ); + inherited; +end; + +//----------------------------------------------------- + + +end. diff --git a/Addons/KOLHashs.PAS b/Addons/KOLHashs.PAS new file mode 100644 index 0000000..e37f4ff --- /dev/null +++ b/Addons/KOLHashs.PAS @@ -0,0 +1,5175 @@ +unit KOLHashs; + +interface + +uses Windows, KOL; + +type + PHAVAL = ^THAVAL; + THAVAL = object(TObj) + protected + // code + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..7] of DWord; + HashBuffer: array[0..127] of byte; + fInitialized: Boolean; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLHAVAL = PHAVAL; + + PMD4 = ^TMD4; + TMD4 = object(TObj) + protected + // code + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..3] of DWord; + HashBuffer: array[0..63] of byte; + fInitialized: Boolean; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLMD4 = PMD4; + + PMD5 = ^TMD5; + TMD5 = object(TObj) + protected + // code + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..3] of DWord; + HashBuffer: array[0..63] of byte; + fInitialized: Boolean; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLMD5 = PMD5; + + PRMD128 = ^TRMD128; + TRMD128 = object(TObj) + protected + // code + fInitialized: Boolean; + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..3] of DWord; + HashBuffer: array[0..63] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLRMD128 = PRMD128; + + PRMD160 = ^TRMD160; + TRMD160 = object(TObj) + protected + // code + fInitialized: Boolean; + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..4] of DWord; + HashBuffer: array[0..63] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLRMD160 = PRMD160; + + PSHA1 = ^TSHA1; + TSHA1 = object(TObj) + protected + // code + fInitialized: Boolean; + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..4] of DWord; + HashBuffer: array[0..63] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLSHA1 = PSHA1; + + PSHA256 = ^TSHA256; + TSHA256 = object(TObj) + protected + // code + fInitialized: Boolean; + LenHi, LenLo: longword; + Index: DWord; + CurrentHash: array[0..7] of DWord; + HashBuffer: array[0..63] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLSHA256 = PSHA256; + + PSHA384 = ^TSHA384; + TSHA384 = object(TObj) + protected + fInitialized: Boolean; + LenHi, LenLo: int64; + Index: DWord; + CurrentHash: array[0..7] of int64; + HashBuffer: array[0..127] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLSHA384 = PSHA384; + + PSHA512 = ^TSHA512; + TSHA512 = object(TObj) + protected + // code + fInitialized: Boolean; + LenHi, LenLo: Int64; + Index: DWORD; + CurrentHash: array[0..7] of Int64; + HashBuffer: array[0..127] of Byte; + procedure Compress; + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: DWORD); + procedure UpdateStr(const s: string); + procedure Final(var Digest); + destructor Destroy; virtual; + end; + + TKOLSHA512 = PSHA512; + +const +{$WARNINGS OFF} + tiger1 : array[0..255] of int64 = ( + $02AAB17CF7E90C5E, $AC424B03E243A8EC, + $72CD5BE30DD5FCD3, $6D019B93F6F97F3A, + $CD9978FFD21F9193, $7573A1C9708029E2, + $B164326B922A83C3, $46883EEE04915870, + $EAACE3057103ECE6, $C54169B808A3535C, + $4CE754918DDEC47C, $0AA2F4DFDC0DF40C, + $10B76F18A74DBEFA, $C6CCB6235AD1AB6A, + $13726121572FE2FF, $1A488C6F199D921E, + $4BC9F9F4DA0007CA, $26F5E6F6E85241C7, + $859079DBEA5947B6, $4F1885C5C99E8C92, + $D78E761EA96F864B, $8E36428C52B5C17D, + $69CF6827373063C1, $B607C93D9BB4C56E, + $7D820E760E76B5EA, $645C9CC6F07FDC42, + $BF38A078243342E0, $5F6B343C9D2E7D04, + $F2C28AEB600B0EC6, $6C0ED85F7254BCAC, + $71592281A4DB4FE5, $1967FA69CE0FED9F, + $FD5293F8B96545DB, $C879E9D7F2A7600B, + $860248920193194E, $A4F9533B2D9CC0B3, + $9053836C15957613, $DB6DCF8AFC357BF1, + $18BEEA7A7A370F57, $037117CA50B99066, + $6AB30A9774424A35, $F4E92F02E325249B, + $7739DB07061CCAE1, $D8F3B49CECA42A05, + $BD56BE3F51382F73, $45FAED5843B0BB28, + $1C813D5C11BF1F83, $8AF0E4B6D75FA169, + $33EE18A487AD9999, $3C26E8EAB1C94410, + $B510102BC0A822F9, $141EEF310CE6123B, + $FC65B90059DDB154, $E0158640C5E0E607, + $884E079826C3A3CF, $930D0D9523C535FD, + $35638D754E9A2B00, $4085FCCF40469DD5, + $C4B17AD28BE23A4C, $CAB2F0FC6A3E6A2E, + $2860971A6B943FCD, $3DDE6EE212E30446, + $6222F32AE01765AE, $5D550BB5478308FE, + $A9EFA98DA0EDA22A, $C351A71686C40DA7, + $1105586D9C867C84, $DCFFEE85FDA22853, + $CCFBD0262C5EEF76, $BAF294CB8990D201, + $E69464F52AFAD975, $94B013AFDF133E14, + $06A7D1A32823C958, $6F95FE5130F61119, + $D92AB34E462C06C0, $ED7BDE33887C71D2, + $79746D6E6518393E, $5BA419385D713329, + $7C1BA6B948A97564, $31987C197BFDAC67, + $DE6C23C44B053D02, $581C49FED002D64D, + $DD474D6338261571, $AA4546C3E473D062, + $928FCE349455F860, $48161BBACAAB94D9, + $63912430770E6F68, $6EC8A5E602C6641C, + $87282515337DDD2B, $2CDA6B42034B701B, + $B03D37C181CB096D, $E108438266C71C6F, + $2B3180C7EB51B255, $DF92B82F96C08BBC, + $5C68C8C0A632F3BA, $5504CC861C3D0556, + $ABBFA4E55FB26B8F, $41848B0AB3BACEB4, + $B334A273AA445D32, $BCA696F0A85AD881, + $24F6EC65B528D56C, $0CE1512E90F4524A, + $4E9DD79D5506D35A, $258905FAC6CE9779, + $2019295B3E109B33, $F8A9478B73A054CC, + $2924F2F934417EB0, $3993357D536D1BC4, + $38A81AC21DB6FF8B, $47C4FBF17D6016BF, + $1E0FAADD7667E3F5, $7ABCFF62938BEB96, + $A78DAD948FC179C9, $8F1F98B72911E50D, + $61E48EAE27121A91, $4D62F7AD31859808, + $ECEBA345EF5CEAEB, $F5CEB25EBC9684CE, + $F633E20CB7F76221, $A32CDF06AB8293E4, + $985A202CA5EE2CA4, $CF0B8447CC8A8FB1, + $9F765244979859A3, $A8D516B1A1240017, + $0BD7BA3EBB5DC726, $E54BCA55B86ADB39, + $1D7A3AFD6C478063, $519EC608E7669EDD, + $0E5715A2D149AA23, $177D4571848FF194, + $EEB55F3241014C22, $0F5E5CA13A6E2EC2, + $8029927B75F5C361, $AD139FABC3D6E436, + $0D5DF1A94CCF402F, $3E8BD948BEA5DFC8, + $A5A0D357BD3FF77E, $A2D12E251F74F645, + $66FD9E525E81A082, $2E0C90CE7F687A49, + $C2E8BCBEBA973BC5, $000001BCE509745F, + $423777BBE6DAB3D6, $D1661C7EAEF06EB5, + $A1781F354DAACFD8, $2D11284A2B16AFFC, + $F1FC4F67FA891D1F, $73ECC25DCB920ADA, + $AE610C22C2A12651, $96E0A810D356B78A, + $5A9A381F2FE7870F, $D5AD62EDE94E5530, + $D225E5E8368D1427, $65977B70C7AF4631, + $99F889B2DE39D74F, $233F30BF54E1D143, + $9A9675D3D9A63C97, $5470554FF334F9A8, + $166ACB744A4F5688, $70C74CAAB2E4AEAD, + $F0D091646F294D12, $57B82A89684031D1, + $EFD95A5A61BE0B6B, $2FBD12E969F2F29A, + $9BD37013FEFF9FE8, $3F9B0404D6085A06, + $4940C1F3166CFE15, $09542C4DCDF3DEFB, + $B4C5218385CD5CE3, $C935B7DC4462A641, + $3417F8A68ED3B63F, $B80959295B215B40, + $F99CDAEF3B8C8572, $018C0614F8FCB95D, + $1B14ACCD1A3ACDF3, $84D471F200BB732D, + $C1A3110E95E8DA16, $430A7220BF1A82B8, + $B77E090D39DF210E, $5EF4BD9F3CD05E9D, + $9D4FF6DA7E57A444, $DA1D60E183D4A5F8, + $B287C38417998E47, $FE3EDC121BB31886, + $C7FE3CCC980CCBEF, $E46FB590189BFD03, + $3732FD469A4C57DC, $7EF700A07CF1AD65, + $59C64468A31D8859, $762FB0B4D45B61F6, + $155BAED099047718, $68755E4C3D50BAA6, + $E9214E7F22D8B4DF, $2ADDBF532EAC95F4, + $32AE3909B4BD0109, $834DF537B08E3450, + $FA209DA84220728D, $9E691D9B9EFE23F7, + $0446D288C4AE8D7F, $7B4CC524E169785B, + $21D87F0135CA1385, $CEBB400F137B8AA5, + $272E2B66580796BE, $3612264125C2B0DE, + $057702BDAD1EFBB2, $D4BABB8EACF84BE9, + $91583139641BC67B, $8BDC2DE08036E024, + $603C8156F49F68ED, $F7D236F7DBEF5111, + $9727C4598AD21E80, $A08A0896670A5FD7, + $CB4A8F4309EBA9CB, $81AF564B0F7036A1, + $C0B99AA778199ABD, $959F1EC83FC8E952, + $8C505077794A81B9, $3ACAAF8F056338F0, + $07B43F50627A6778, $4A44AB49F5ECCC77, + $3BC3D6E4B679EE98, $9CC0D4D1CF14108C, + $4406C00B206BC8A0, $82A18854C8D72D89, + $67E366B35C3C432C, $B923DD61102B37F2, + $56AB2779D884271D, $BE83E1B0FF1525AF, + $FB7C65D4217E49A9, $6BDBE0E76D48E7D4, + $08DF828745D9179E, $22EA6A9ADD53BD34, + $E36E141C5622200A, $7F805D1B8CB750EE, + $AFE5C7A59F58E837, $E27F996A4FB1C23C, + $D3867DFB0775F0D0, $D0E673DE6E88891A, + $123AEB9EAFB86C25, $30F1D5D5C145B895, + $BB434A2DEE7269E7, $78CB67ECF931FA38, + $F33B0372323BBF9C, $52D66336FB279C74, + $505F33AC0AFB4EAA, $E8A5CD99A2CCE187, + $534974801E2D30BB, $8D2D5711D5876D90, + $1F1A412891BC038E, $D6E2E71D82E56648, + $74036C3A497732B7, $89B67ED96361F5AB, + $FFED95D8F1EA02A2, $E72B3BD61464D43D, + $A6300F170BDC4820, $EBC18760ED78A77A); + + tiger2 : array[0..255] of int64 = ( + $E6A6BE5A05A12138, $B5A122A5B4F87C98, + $563C6089140B6990, $4C46CB2E391F5DD5, + $D932ADDBC9B79434, $08EA70E42015AFF5, + $D765A6673E478CF1, $C4FB757EAB278D99, + $DF11C6862D6E0692, $DDEB84F10D7F3B16, + $6F2EF604A665EA04, $4A8E0F0FF0E0DFB3, + $A5EDEEF83DBCBA51, $FC4F0A2A0EA4371E, + $E83E1DA85CB38429, $DC8FF882BA1B1CE2, + $CD45505E8353E80D, $18D19A00D4DB0717, + $34A0CFEDA5F38101, $0BE77E518887CAF2, + $1E341438B3C45136, $E05797F49089CCF9, + $FFD23F9DF2591D14, $543DDA228595C5CD, + $661F81FD99052A33, $8736E641DB0F7B76, + $15227725418E5307, $E25F7F46162EB2FA, + $48A8B2126C13D9FE, $AFDC541792E76EEA, + $03D912BFC6D1898F, $31B1AAFA1B83F51B, + $F1AC2796E42AB7D9, $40A3A7D7FCD2EBAC, + $1056136D0AFBBCC5, $7889E1DD9A6D0C85, + $D33525782A7974AA, $A7E25D09078AC09B, + $BD4138B3EAC6EDD0, $920ABFBE71EB9E70, + $A2A5D0F54FC2625C, $C054E36B0B1290A3, + $F6DD59FF62FE932B, $3537354511A8AC7D, + $CA845E9172FADCD4, $84F82B60329D20DC, + $79C62CE1CD672F18, $8B09A2ADD124642C, + $D0C1E96A19D9E726, $5A786A9B4BA9500C, + $0E020336634C43F3, $C17B474AEB66D822, + $6A731AE3EC9BAAC2, $8226667AE0840258, + $67D4567691CAECA5, $1D94155C4875ADB5, + $6D00FD985B813FDF, $51286EFCB774CD06, + $5E8834471FA744AF, $F72CA0AEE761AE2E, + $BE40E4CDAEE8E09A, $E9970BBB5118F665, + $726E4BEB33DF1964, $703B000729199762, + $4631D816F5EF30A7, $B880B5B51504A6BE, + $641793C37ED84B6C, $7B21ED77F6E97D96, + $776306312EF96B73, $AE528948E86FF3F4, + $53DBD7F286A3F8F8, $16CADCE74CFC1063, + $005C19BDFA52C6DD, $68868F5D64D46AD3, + $3A9D512CCF1E186A, $367E62C2385660AE, + $E359E7EA77DCB1D7, $526C0773749ABE6E, + $735AE5F9D09F734B, $493FC7CC8A558BA8, + $B0B9C1533041AB45, $321958BA470A59BD, + $852DB00B5F46C393, $91209B2BD336B0E5, + $6E604F7D659EF19F, $B99A8AE2782CCB24, + $CCF52AB6C814C4C7, $4727D9AFBE11727B, + $7E950D0C0121B34D, $756F435670AD471F, + $F5ADD442615A6849, $4E87E09980B9957A, + $2ACFA1DF50AEE355, $D898263AFD2FD556, + $C8F4924DD80C8FD6, $CF99CA3D754A173A, + $FE477BACAF91BF3C, $ED5371F6D690C12D, + $831A5C285E687094, $C5D3C90A3708A0A4, + $0F7F903717D06580, $19F9BB13B8FDF27F, + $B1BD6F1B4D502843, $1C761BA38FFF4012, + $0D1530C4E2E21F3B, $8943CE69A7372C8A, + $E5184E11FEB5CE66, $618BDB80BD736621, + $7D29BAD68B574D0B, $81BB613E25E6FE5B, + $071C9C10BC07913F, $C7BEEB7909AC2D97, + $C3E58D353BC5D757, $EB017892F38F61E8, + $D4EFFB9C9B1CC21A, $99727D26F494F7AB, + $A3E063A2956B3E03, $9D4A8B9A4AA09C30, + $3F6AB7D500090FB4, $9CC0F2A057268AC0, + $3DEE9D2DEDBF42D1, $330F49C87960A972, + $C6B2720287421B41, $0AC59EC07C00369C, + $EF4EAC49CB353425, $F450244EEF0129D8, + $8ACC46E5CAF4DEB6, $2FFEAB63989263F7, + $8F7CB9FE5D7A4578, $5BD8F7644E634635, + $427A7315BF2DC900, $17D0C4AA2125261C, + $3992486C93518E50, $B4CBFEE0A2D7D4C3, + $7C75D6202C5DDD8D, $DBC295D8E35B6C61, + $60B369D302032B19, $CE42685FDCE44132, + $06F3DDB9DDF65610, $8EA4D21DB5E148F0, + $20B0FCE62FCD496F, $2C1B912358B0EE31, + $B28317B818F5A308, $A89C1E189CA6D2CF, + $0C6B18576AAADBC8, $B65DEAA91299FAE3, + $FB2B794B7F1027E7, $04E4317F443B5BEB, + $4B852D325939D0A6, $D5AE6BEEFB207FFC, + $309682B281C7D374, $BAE309A194C3B475, + $8CC3F97B13B49F05, $98A9422FF8293967, + $244B16B01076FF7C, $F8BF571C663D67EE, + $1F0D6758EEE30DA1, $C9B611D97ADEB9B7, + $B7AFD5887B6C57A2, $6290AE846B984FE1, + $94DF4CDEACC1A5FD, $058A5BD1C5483AFF, + $63166CC142BA3C37, $8DB8526EB2F76F40, + $E10880036F0D6D4E, $9E0523C9971D311D, + $45EC2824CC7CD691, $575B8359E62382C9, + $FA9E400DC4889995, $D1823ECB45721568, + $DAFD983B8206082F, $AA7D29082386A8CB, + $269FCD4403B87588, $1B91F5F728BDD1E0, + $E4669F39040201F6, $7A1D7C218CF04ADE, + $65623C29D79CE5CE, $2368449096C00BB1, + $AB9BF1879DA503BA, $BC23ECB1A458058E, + $9A58DF01BB401ECC, $A070E868A85F143D, + $4FF188307DF2239E, $14D565B41A641183, + $EE13337452701602, $950E3DCF3F285E09, + $59930254B9C80953, $3BF299408930DA6D, + $A955943F53691387, $A15EDECAA9CB8784, + $29142127352BE9A0, $76F0371FFF4E7AFB, + $0239F450274F2228, $BB073AF01D5E868B, + $BFC80571C10E96C1, $D267088568222E23, + $9671A3D48E80B5B0, $55B5D38AE193BB81, + $693AE2D0A18B04B8, $5C48B4ECADD5335F, + $FD743B194916A1CA, $2577018134BE98C4, + $E77987E83C54A4AD, $28E11014DA33E1B9, + $270CC59E226AA213, $71495F756D1A5F60, + $9BE853FB60AFEF77, $ADC786A7F7443DBF, + $0904456173B29A82, $58BC7A66C232BD5E, + $F306558C673AC8B2, $41F639C6B6C9772A, + $216DEFE99FDA35DA, $11640CC71C7BE615, + $93C43694565C5527, $EA038E6246777839, + $F9ABF3CE5A3E2469, $741E768D0FD312D2, + $0144B883CED652C6, $C20B5A5BA33F8552, + $1AE69633C3435A9D, $97A28CA4088CFDEC, + $8824A43C1E96F420, $37612FA66EEEA746, + $6B4CB165F9CF0E5A, $43AA1C06A0ABFB4A, + $7F4DC26FF162796B, $6CBACC8E54ED9B0F, + $A6B7FFEFD2BB253E, $2E25BC95B0A29D4F, + $86D6A58BDEF1388C, $DED74AC576B6F054, + $8030BDBC2B45805D, $3C81AF70E94D9289, + $3EFF6DDA9E3100DB, $B38DC39FDFCC8847, + $123885528D17B87E, $F2DA0ED240B1B642, + $44CEFADCD54BF9A9, $1312200E433C7EE6, + $9FFCC84F3A78C748, $F0CD1F72248576BB, + $EC6974053638CFE4, $2BA7B67C0CEC4E4C, + $AC2F4DF3E5CE32ED, $CB33D14326EA4C11, + $A4E9044CC77E58BC, $5F513293D934FCEF, + $5DC9645506E55444, $50DE418F317DE40A, + $388CB31A69DDE259, $2DB4A83455820A86, + $9010A91E84711AE9, $4DF7F0B7B1498371, + $D62A2EABC0977179, $22FAC097AA8D5C0E); + + tiger3 : array[0..255] of int64 = ( + $F49FCC2FF1DAF39B, $487FD5C66FF29281, + $E8A30667FCDCA83F, $2C9B4BE3D2FCCE63, + $DA3FF74B93FBBBC2, $2FA165D2FE70BA66, + $A103E279970E93D4, $BECDEC77B0E45E71, + $CFB41E723985E497, $B70AAA025EF75017, + $D42309F03840B8E0, $8EFC1AD035898579, + $96C6920BE2B2ABC5, $66AF4163375A9172, + $2174ABDCCA7127FB, $B33CCEA64A72FF41, + $F04A4933083066A5, $8D970ACDD7289AF5, + $8F96E8E031C8C25E, $F3FEC02276875D47, + $EC7BF310056190DD, $F5ADB0AEBB0F1491, + $9B50F8850FD58892, $4975488358B74DE8, + $A3354FF691531C61, $0702BBE481D2C6EE, + $89FB24057DEDED98, $AC3075138596E902, + $1D2D3580172772ED, $EB738FC28E6BC30D, + $5854EF8F63044326, $9E5C52325ADD3BBE, + $90AA53CF325C4623, $C1D24D51349DD067, + $2051CFEEA69EA624, $13220F0A862E7E4F, + $CE39399404E04864, $D9C42CA47086FCB7, + $685AD2238A03E7CC, $066484B2AB2FF1DB, + $FE9D5D70EFBF79EC, $5B13B9DD9C481854, + $15F0D475ED1509AD, $0BEBCD060EC79851, + $D58C6791183AB7F8, $D1187C5052F3EEE4, + $C95D1192E54E82FF, $86EEA14CB9AC6CA2, + $3485BEB153677D5D, $DD191D781F8C492A, + $F60866BAA784EBF9, $518F643BA2D08C74, + $8852E956E1087C22, $A768CB8DC410AE8D, + $38047726BFEC8E1A, $A67738B4CD3B45AA, + $AD16691CEC0DDE19, $C6D4319380462E07, + $C5A5876D0BA61938, $16B9FA1FA58FD840, + $188AB1173CA74F18, $ABDA2F98C99C021F, + $3E0580AB134AE816, $5F3B05B773645ABB, + $2501A2BE5575F2F6, $1B2F74004E7E8BA9, + $1CD7580371E8D953, $7F6ED89562764E30, + $B15926FF596F003D, $9F65293DA8C5D6B9, + $6ECEF04DD690F84C, $4782275FFF33AF88, + $E41433083F820801, $FD0DFE409A1AF9B5, + $4325A3342CDB396B, $8AE77E62B301B252, + $C36F9E9F6655615A, $85455A2D92D32C09, + $F2C7DEA949477485, $63CFB4C133A39EBA, + $83B040CC6EBC5462, $3B9454C8FDB326B0, + $56F56A9E87FFD78C, $2DC2940D99F42BC6, + $98F7DF096B096E2D, $19A6E01E3AD852BF, + $42A99CCBDBD4B40B, $A59998AF45E9C559, + $366295E807D93186, $6B48181BFAA1F773, + $1FEC57E2157A0A1D, $4667446AF6201AD5, + $E615EBCACFB0F075, $B8F31F4F68290778, + $22713ED6CE22D11E, $3057C1A72EC3C93B, + $CB46ACC37C3F1F2F, $DBB893FD02AAF50E, + $331FD92E600B9FCF, $A498F96148EA3AD6, + $A8D8426E8B6A83EA, $A089B274B7735CDC, + $87F6B3731E524A11, $118808E5CBC96749, + $9906E4C7B19BD394, $AFED7F7E9B24A20C, + $6509EADEEB3644A7, $6C1EF1D3E8EF0EDE, + $B9C97D43E9798FB4, $A2F2D784740C28A3, + $7B8496476197566F, $7A5BE3E6B65F069D, + $F96330ED78BE6F10, $EEE60DE77A076A15, + $2B4BEE4AA08B9BD0, $6A56A63EC7B8894E, + $02121359BA34FEF4, $4CBF99F8283703FC, + $398071350CAF30C8, $D0A77A89F017687A, + $F1C1A9EB9E423569, $8C7976282DEE8199, + $5D1737A5DD1F7ABD, $4F53433C09A9FA80, + $FA8B0C53DF7CA1D9, $3FD9DCBC886CCB77, + $C040917CA91B4720, $7DD00142F9D1DCDF, + $8476FC1D4F387B58, $23F8E7C5F3316503, + $032A2244E7E37339, $5C87A5D750F5A74B, + $082B4CC43698992E, $DF917BECB858F63C, + $3270B8FC5BF86DDA, $10AE72BB29B5DD76, + $576AC94E7700362B, $1AD112DAC61EFB8F, + $691BC30EC5FAA427, $FF246311CC327143, + $3142368E30E53206, $71380E31E02CA396, + $958D5C960AAD76F1, $F8D6F430C16DA536, + $C8FFD13F1BE7E1D2, $7578AE66004DDBE1, + $05833F01067BE646, $BB34B5AD3BFE586D, + $095F34C9A12B97F0, $247AB64525D60CA8, + $DCDBC6F3017477D1, $4A2E14D4DECAD24D, + $BDB5E6D9BE0A1EEB, $2A7E70F7794301AB, + $DEF42D8A270540FD, $01078EC0A34C22C1, + $E5DE511AF4C16387, $7EBB3A52BD9A330A, + $77697857AA7D6435, $004E831603AE4C32, + $E7A21020AD78E312, $9D41A70C6AB420F2, + $28E06C18EA1141E6, $D2B28CBD984F6B28, + $26B75F6C446E9D83, $BA47568C4D418D7F, + $D80BADBFE6183D8E, $0E206D7F5F166044, + $E258A43911CBCA3E, $723A1746B21DC0BC, + $C7CAA854F5D7CDD3, $7CAC32883D261D9C, + $7690C26423BA942C, $17E55524478042B8, + $E0BE477656A2389F, $4D289B5E67AB2DA0, + $44862B9C8FBBFD31, $B47CC8049D141365, + $822C1B362B91C793, $4EB14655FB13DFD8, + $1ECBBA0714E2A97B, $6143459D5CDE5F14, + $53A8FBF1D5F0AC89, $97EA04D81C5E5B00, + $622181A8D4FDB3F3, $E9BCD341572A1208, + $1411258643CCE58A, $9144C5FEA4C6E0A4, + $0D33D06565CF620F, $54A48D489F219CA1, + $C43E5EAC6D63C821, $A9728B3A72770DAF, + $D7934E7B20DF87EF, $E35503B61A3E86E5, + $CAE321FBC819D504, $129A50B3AC60BFA6, + $CD5E68EA7E9FB6C3, $B01C90199483B1C7, + $3DE93CD5C295376C, $AED52EDF2AB9AD13, + $2E60F512C0A07884, $BC3D86A3E36210C9, + $35269D9B163951CE, $0C7D6E2AD0CDB5FA, + $59E86297D87F5733, $298EF221898DB0E7, + $55000029D1A5AA7E, $8BC08AE1B5061B45, + $C2C31C2B6C92703A, $94CC596BAF25EF42, + $0A1D73DB22540456, $04B6A0F9D9C4179A, + $EFFDAFA2AE3D3C60, $F7C8075BB49496C4, + $9CC5C7141D1CD4E3, $78BD1638218E5534, + $B2F11568F850246A, $EDFABCFA9502BC29, + $796CE5F2DA23051B, $AAE128B0DC93537C, + $3A493DA0EE4B29AE, $B5DF6B2C416895D7, + $FCABBD25122D7F37, $70810B58105DC4B1, + $E10FDD37F7882A90, $524DCAB5518A3F5C, + $3C9E85878451255B, $4029828119BD34E2, + $74A05B6F5D3CECCB, $B610021542E13ECA, + $0FF979D12F59E2AC, $6037DA27E4F9CC50, + $5E92975A0DF1847D, $D66DE190D3E623FE, + $5032D6B87B568048, $9A36B7CE8235216E, + $80272A7A24F64B4A, $93EFED8B8C6916F7, + $37DDBFF44CCE1555, $4B95DB5D4B99BD25, + $92D3FDA169812FC0, $FB1A4A9A90660BB6, + $730C196946A4B9B2, $81E289AA7F49DA68, + $64669A0F83B1A05F, $27B3FF7D9644F48B, + $CC6B615C8DB675B3, $674F20B9BCEBBE95, + $6F31238275655982, $5AE488713E45CF05, + $BF619F9954C21157, $EABAC46040A8EAE9, + $454C6FE9F2C0C1CD, $419CF6496412691C, + $D3DC3BEF265B0F70, $6D0E60F5C3578A9E); + + tiger4 : array[0..255] of int64 = ( + $5B0E608526323C55, $1A46C1A9FA1B59F5, + $A9E245A17C4C8FFA, $65CA5159DB2955D7, + $05DB0A76CE35AFC2, $81EAC77EA9113D45, + $528EF88AB6AC0A0D, $A09EA253597BE3FF, + $430DDFB3AC48CD56, $C4B3A67AF45CE46F, + $4ECECFD8FBE2D05E, $3EF56F10B39935F0, + $0B22D6829CD619C6, $17FD460A74DF2069, + $6CF8CC8E8510ED40, $D6C824BF3A6ECAA7, + $61243D581A817049, $048BACB6BBC163A2, + $D9A38AC27D44CC32, $7FDDFF5BAAF410AB, + $AD6D495AA804824B, $E1A6A74F2D8C9F94, + $D4F7851235DEE8E3, $FD4B7F886540D893, + $247C20042AA4BFDA, $096EA1C517D1327C, + $D56966B4361A6685, $277DA5C31221057D, + $94D59893A43ACFF7, $64F0C51CCDC02281, + $3D33BCC4FF6189DB, $E005CB184CE66AF1, + $FF5CCD1D1DB99BEA, $B0B854A7FE42980F, + $7BD46A6A718D4B9F, $D10FA8CC22A5FD8C, + $D31484952BE4BD31, $C7FA975FCB243847, + $4886ED1E5846C407, $28CDDB791EB70B04, + $C2B00BE2F573417F, $5C9590452180F877, + $7A6BDDFFF370EB00, $CE509E38D6D9D6A4, + $EBEB0F00647FA702, $1DCC06CF76606F06, + $E4D9F28BA286FF0A, $D85A305DC918C262, + $475B1D8732225F54, $2D4FB51668CCB5FE, + $A679B9D9D72BBA20, $53841C0D912D43A5, + $3B7EAA48BF12A4E8, $781E0E47F22F1DDF, + $EFF20CE60AB50973, $20D261D19DFFB742, + $16A12B03062A2E39, $1960EB2239650495, + $251C16FED50EB8B8, $9AC0C330F826016E, + $ED152665953E7671, $02D63194A6369570, + $5074F08394B1C987, $70BA598C90B25CE1, + $794A15810B9742F6, $0D5925E9FCAF8C6C, + $3067716CD868744E, $910AB077E8D7731B, + $6A61BBDB5AC42F61, $93513EFBF0851567, + $F494724B9E83E9D5, $E887E1985C09648D, + $34B1D3C675370CFD, $DC35E433BC0D255D, + $D0AAB84234131BE0, $08042A50B48B7EAF, + $9997C4EE44A3AB35, $829A7B49201799D0, + $263B8307B7C54441, $752F95F4FD6A6CA6, + $927217402C08C6E5, $2A8AB754A795D9EE, + $A442F7552F72943D, $2C31334E19781208, + $4FA98D7CEAEE6291, $55C3862F665DB309, + $BD0610175D53B1F3, $46FE6CB840413F27, + $3FE03792DF0CFA59, $CFE700372EB85E8F, + $A7BE29E7ADBCE118, $E544EE5CDE8431DD, + $8A781B1B41F1873E, $A5C94C78A0D2F0E7, + $39412E2877B60728, $A1265EF3AFC9A62C, + $BCC2770C6A2506C5, $3AB66DD5DCE1CE12, + $E65499D04A675B37, $7D8F523481BFD216, + $0F6F64FCEC15F389, $74EFBE618B5B13C8, + $ACDC82B714273E1D, $DD40BFE003199D17, + $37E99257E7E061F8, $FA52626904775AAA, + $8BBBF63A463D56F9, $F0013F1543A26E64, + $A8307E9F879EC898, $CC4C27A4150177CC, + $1B432F2CCA1D3348, $DE1D1F8F9F6FA013, + $606602A047A7DDD6, $D237AB64CC1CB2C7, + $9B938E7225FCD1D3, $EC4E03708E0FF476, + $FEB2FBDA3D03C12D, $AE0BCED2EE43889A, + $22CB8923EBFB4F43, $69360D013CF7396D, + $855E3602D2D4E022, $073805BAD01F784C, + $33E17A133852F546, $DF4874058AC7B638, + $BA92B29C678AA14A, $0CE89FC76CFAADCD, + $5F9D4E0908339E34, $F1AFE9291F5923B9, + $6E3480F60F4A265F, $EEBF3A2AB29B841C, + $E21938A88F91B4AD, $57DFEFF845C6D3C3, + $2F006B0BF62CAAF2, $62F479EF6F75EE78, + $11A55AD41C8916A9, $F229D29084FED453, + $42F1C27B16B000E6, $2B1F76749823C074, + $4B76ECA3C2745360, $8C98F463B91691BD, + $14BCC93CF1ADE66A, $8885213E6D458397, + $8E177DF0274D4711, $B49B73B5503F2951, + $10168168C3F96B6B, $0E3D963B63CAB0AE, + $8DFC4B5655A1DB14, $F789F1356E14DE5C, + $683E68AF4E51DAC1, $C9A84F9D8D4B0FD9, + $3691E03F52A0F9D1, $5ED86E46E1878E80, + $3C711A0E99D07150, $5A0865B20C4E9310, + $56FBFC1FE4F0682E, $EA8D5DE3105EDF9B, + $71ABFDB12379187A, $2EB99DE1BEE77B9C, + $21ECC0EA33CF4523, $59A4D7521805C7A1, + $3896F5EB56AE7C72, $AA638F3DB18F75DC, + $9F39358DABE9808E, $B7DEFA91C00B72AC, + $6B5541FD62492D92, $6DC6DEE8F92E4D5B, + $353F57ABC4BEEA7E, $735769D6DA5690CE, + $0A234AA642391484, $F6F9508028F80D9D, + $B8E319A27AB3F215, $31AD9C1151341A4D, + $773C22A57BEF5805, $45C7561A07968633, + $F913DA9E249DBE36, $DA652D9B78A64C68, + $4C27A97F3BC334EF, $76621220E66B17F4, + $967743899ACD7D0B, $F3EE5BCAE0ED6782, + $409F753600C879FC, $06D09A39B5926DB6, + $6F83AEB0317AC588, $01E6CA4A86381F21, + $66FF3462D19F3025, $72207C24DDFD3BFB, + $4AF6B6D3E2ECE2EB, $9C994DBEC7EA08DE, + $49ACE597B09A8BC4, $B38C4766CF0797BA, + $131B9373C57C2A75, $B1822CCE61931E58, + $9D7555B909BA1C0C, $127FAFDD937D11D2, + $29DA3BADC66D92E4, $A2C1D57154C2ECBC, + $58C5134D82F6FE24, $1C3AE3515B62274F, + $E907C82E01CB8126, $F8ED091913E37FCB, + $3249D8F9C80046C9, $80CF9BEDE388FB63, + $1881539A116CF19E, $5103F3F76BD52457, + $15B7E6F5AE47F7A8, $DBD7C6DED47E9CCF, + $44E55C410228BB1A, $B647D4255EDB4E99, + $5D11882BB8AAFC30, $F5098BBB29D3212A, + $8FB5EA14E90296B3, $677B942157DD025A, + $FB58E7C0A390ACB5, $89D3674C83BD4A01, + $9E2DA4DF4BF3B93B, $FCC41E328CAB4829, + $03F38C96BA582C52, $CAD1BDBD7FD85DB2, + $BBB442C16082AE83, $B95FE86BA5DA9AB0, + $B22E04673771A93F, $845358C9493152D8, + $BE2A488697B4541E, $95A2DC2DD38E6966, + $C02C11AC923C852B, $2388B1990DF2A87B, + $7C8008FA1B4F37BE, $1F70D0C84D54E503, + $5490ADEC7ECE57D4, $002B3C27D9063A3A, + $7EAEA3848030A2BF, $C602326DED2003C0, + $83A7287D69A94086, $C57A5FCB30F57A8A, + $B56844E479EBE779, $A373B40F05DCBCE9, + $D71A786E88570EE2, $879CBACDBDE8F6A0, + $976AD1BCC164A32F, $AB21E25E9666D78B, + $901063AAE5E5C33C, $9818B34448698D90, + $E36487AE3E1E8ABB, $AFBDF931893BDCB4, + $6345A0DC5FBBD519, $8628FE269B9465CA, + $1E5D01603F9C51EC, $4DE44006A15049B7, + $BF6C70E5F776CBB1, $411218F2EF552BED, + $CB0C0708705A36A3, $E74D14754F986044, + $CD56D9430EA8280E, $C12591D7535F5065, + $C83223F1720AEF96, $C3A0396F7363A51F); +{$WARNINGS ON} + +type + PTIGER = ^TTIGER; + TTIGER = object(TObj) + protected + // code + fInitialized: Boolean; + Len: int64; + Index: DWord; + CurrentHash: array[0..2] of int64; + HashBuffer: array[0..63] of byte; + procedure Compress; + + public + // code + procedure InitHash; + procedure Burn; + procedure Update(const Buffer; Size: longword); + procedure UpdateStr(const Str: string); + procedure Final(var Digest); + + destructor Destroy; virtual; + end; + + TKOLTIGER = PTIGER; + +function NewHAVAL: PHAVAL; +function NewMD4: PMD4; +function NewMD5: PMD5; +function NewRMD128: PRMD128; +function NewRMD160: PRMD160; +function NewSHA1: PSHA1; +function NewSHA256: PSHA256; +function NewSHA384: PSHA384; +function NewSHA512: PSHA512; +function NewTIGER: PTIGER; + +{ Choose how many passes (previous versions of DCPcrypt uses 5 passes) } +{ ONLY UNCOMMENT ONE! } +//{$DEFINE PASS3} +//{$DEFINE PASS4} +{$DEFINE PASS5} + +{ Choose digest length (previous versions of DCPcrypt uses 256bits) } +{ ONLY UNCOMMENT ONE! } +//{$DEFINE DIGEST128} +//{$DEFINE DIGEST160} +//{$DEFINE DIGEST192} +//{$DEFINE DIGEST224} +{$DEFINE DIGEST256} + +implementation +{$R-}{$Q-} + +// uses CommCtrl, ShellApi; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor THAVAL.Destroy; +begin + if fInitialized then + Burn; + + // All Strings := ''; + // Free_And_Nil(All PObj); + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewHAVAL; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// +{$R-}{$Q-} + +procedure THAVAL.Compress; +var + t7, t6, t5, t4, t3, t2, t1, t0: DWord; + W : array[0..31] of DWord; + Temp : dword; +begin + t0 := CurrentHash[0]; + t1 := CurrentHash[1]; + t2 := CurrentHash[2]; + t3 := CurrentHash[3]; + t4 := CurrentHash[4]; + t5 := CurrentHash[5]; + t6 := CurrentHash[6]; + t7 := CurrentHash[7]; + Move(HashBuffer, W, Sizeof(W)); + +{$IFDEF PASS3} + //{$INCLUDE DCPhaval3.inc} + temp := (t2 and (t4 xor t3) xor t6 and t0 xor t5 and t1 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0]; + temp := (t1 and (t3 xor t2) xor t5 and t7 xor t4 and t0 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[1]; + temp := (t0 and (t2 xor t1) xor t4 and t6 xor t3 and t7 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[2]; + temp := (t7 and (t1 xor t0) xor t3 and t5 xor t2 and t6 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3]; + temp := (t6 and (t0 xor t7) xor t2 and t4 xor t1 and t5 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[4]; + temp := (t5 and (t7 xor t6) xor t1 and t3 xor t0 and t4 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[5]; + temp := (t4 and (t6 xor t5) xor t0 and t2 xor t7 and t3 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[6]; + temp := (t3 and (t5 xor t4) xor t7 and t1 xor t6 and t2 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[7]; + + temp := (t2 and (t4 xor t3) xor t6 and t0 xor t5 and t1 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[8]; + temp := (t1 and (t3 xor t2) xor t5 and t7 xor t4 and t0 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9]; + temp := (t0 and (t2 xor t1) xor t4 and t6 xor t3 and t7 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[10]; + temp := (t7 and (t1 xor t0) xor t3 and t5 xor t2 and t6 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[11]; + temp := (t6 and (t0 xor t7) xor t2 and t4 xor t1 and t5 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[12]; + temp := (t5 and (t7 xor t6) xor t1 and t3 xor t0 and t4 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[13]; + temp := (t4 and (t6 xor t5) xor t0 and t2 xor t7 and t3 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[14]; + temp := (t3 and (t5 xor t4) xor t7 and t1 xor t6 and t2 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[15]; + + temp := (t2 and (t4 xor t3) xor t6 and t0 xor t5 and t1 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[16]; + temp := (t1 and (t3 xor t2) xor t5 and t7 xor t4 and t0 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[17]; + temp := (t0 and (t2 xor t1) xor t4 and t6 xor t3 and t7 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[18]; + temp := (t7 and (t1 xor t0) xor t3 and t5 xor t2 and t6 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[19]; + temp := (t6 and (t0 xor t7) xor t2 and t4 xor t1 and t5 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[20]; + temp := (t5 and (t7 xor t6) xor t1 and t3 xor t0 and t4 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[21]; + temp := (t4 and (t6 xor t5) xor t0 and t2 xor t7 and t3 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[22]; + temp := (t3 and (t5 xor t4) xor t7 and t1 xor t6 and t2 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[23]; + + temp := (t2 and (t4 xor t3) xor t6 and t0 xor t5 and t1 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[24]; + temp := (t1 and (t3 xor t2) xor t5 and t7 xor t4 and t0 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[25]; + temp := (t0 and (t2 xor t1) xor t4 and t6 xor t3 and t7 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26]; + temp := (t7 and (t1 xor t0) xor t3 and t5 xor t2 and t6 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[27]; + temp := (t6 and (t0 xor t7) xor t2 and t4 xor t1 and t5 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28]; + temp := (t5 and (t7 xor t6) xor t1 and t3 xor t0 and t4 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[29]; + temp := (t4 and (t6 xor t5) xor t0 and t2 xor t7 and t3 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[30]; + temp := (t3 and (t5 xor t4) xor t7 and t1 xor t6 and t2 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[31]; + + temp := (t5 and (t3 and not t0 xor t1 and t2 xor t4 xor t6) xor t1 and (t3 xor t2) xor t0 and t2 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[5] + $452821E6; + temp := (t4 and (t2 and not t7 xor t0 and t1 xor t3 xor t5) xor t0 and (t2 xor t1) xor t7 and t1 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $38D01377; + temp := (t3 and (t1 and not t6 xor t7 and t0 xor t2 xor t4) xor t7 and (t1 xor t0) xor t6 and t0 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26] + $BE5466CF; + temp := (t2 and (t0 and not t5 xor t6 and t7 xor t1 xor t3) xor t6 and (t0 xor t7) xor t5 and t7 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[18] + $34E90C6C; + temp := (t1 and (t7 and not t4 xor t5 and t6 xor t0 xor t2) xor t5 and (t7 xor t6) xor t4 and t6 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[11] + $C0AC29B7; + temp := (t0 and (t6 and not t3 xor t4 and t5 xor t7 xor t1) xor t4 and (t6 xor t5) xor t3 and t5 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[28] + $C97C50DD; + temp := (t7 and (t5 and not t2 xor t3 and t4 xor t6 xor t0) xor t3 and (t5 xor t4) xor t2 and t4 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[7] + $3F84D5B5; + temp := (t6 and (t4 and not t1 xor t2 and t3 xor t5 xor t7) xor t2 and (t4 xor t3) xor t1 and t3 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[16] + $B5470917; + + temp := (t5 and (t3 and not t0 xor t1 and t2 xor t4 xor t6) xor t1 and (t3 xor t2) xor t0 and t2 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0] + $9216D5D9; + temp := (t4 and (t2 and not t7 xor t0 and t1 xor t3 xor t5) xor t0 and (t2 xor t1) xor t7 and t1 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[23] + $8979FB1B; + temp := (t3 and (t1 and not t6 xor t7 and t0 xor t2 xor t4) xor t7 and (t1 xor t0) xor t6 and t0 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[20] + $D1310BA6; + temp := (t2 and (t0 and not t5 xor t6 and t7 xor t1 xor t3) xor t6 and (t0 xor t7) xor t5 and t7 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[22] + $98DFB5AC; + temp := (t1 and (t7 and not t4 xor t5 and t6 xor t0 xor t2) xor t5 and (t7 xor t6) xor t4 and t6 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $2FFD72DB; + temp := (t0 and (t6 and not t3 xor t4 and t5 xor t7 xor t1) xor t4 and (t6 xor t5) xor t3 and t5 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[10] + $D01ADFB7; + temp := (t7 and (t5 and not t2 xor t3 and t4 xor t6 xor t0) xor t3 and (t5 xor t4) xor t2 and t4 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[4] + $B8E1AFED; + temp := (t6 and (t4 and not t1 xor t2 and t3 xor t5 xor t7) xor t2 and (t4 xor t3) xor t1 and t3 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[8] + $6A267E96; + + temp := (t5 and (t3 and not t0 xor t1 and t2 xor t4 xor t6) xor t1 and (t3 xor t2) xor t0 and t2 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[30] + $BA7C9045; + temp := (t4 and (t2 and not t7 xor t0 and t1 xor t3 xor t5) xor t0 and (t2 xor t1) xor t7 and t1 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[3] + $F12C7F99; + temp := (t3 and (t1 and not t6 xor t7 and t0 xor t2 xor t4) xor t7 and (t1 xor t0) xor t6 and t0 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $24A19947; + temp := (t2 and (t0 and not t5 xor t6 and t7 xor t1 xor t3) xor t6 and (t0 xor t7) xor t5 and t7 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[9] + $B3916CF7; + temp := (t1 and (t7 and not t4 xor t5 and t6 xor t0 xor t2) xor t5 and (t7 xor t6) xor t4 and t6 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $0801F2E2; + temp := (t0 and (t6 and not t3 xor t4 and t5 xor t7 xor t1) xor t4 and (t6 xor t5) xor t3 and t5 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[24] + $858EFC16; + temp := (t7 and (t5 and not t2 xor t3 and t4 xor t6 xor t0) xor t3 and (t5 xor t4) xor t2 and t4 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[29] + $636920D8; + temp := (t6 and (t4 and not t1 xor t2 and t3 xor t5 xor t7) xor t2 and (t4 xor t3) xor t1 and t3 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[6] + $71574E69; + + temp := (t5 and (t3 and not t0 xor t1 and t2 xor t4 xor t6) xor t1 and (t3 xor t2) xor t0 and t2 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $A458FEA3; + temp := (t4 and (t2 and not t7 xor t0 and t1 xor t3 xor t5) xor t0 and (t2 xor t1) xor t7 and t1 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[12] + $F4933D7E; + temp := (t3 and (t1 and not t6 xor t7 and t0 xor t2 xor t4) xor t7 and (t1 xor t0) xor t6 and t0 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[15] + $0D95748F; + temp := (t2 and (t0 and not t5 xor t6 and t7 xor t1 xor t3) xor t6 and (t0 xor t7) xor t5 and t7 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[13] + $728EB658; + temp := (t1 and (t7 and not t4 xor t5 and t6 xor t0 xor t2) xor t5 and (t7 xor t6) xor t4 and t6 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[2] + $718BCD58; + temp := (t0 and (t6 and not t3 xor t4 and t5 xor t7 xor t1) xor t4 and (t6 xor t5) xor t3 and t5 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[25] + $82154AEE; + temp := (t7 and (t5 and not t2 xor t3 and t4 xor t6 xor t0) xor t3 and (t5 xor t4) xor t2 and t4 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[31] + $7B54A41D; + temp := (t6 and (t4 and not t1 xor t2 and t3 xor t5 xor t7) xor t2 and (t4 xor t3) xor t1 and t3 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $C25A59B5; + + temp := (t3 and (t5 and t4 xor t6 xor t0) xor t5 and t2 xor t4 and t1 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $9C30D539; + temp := (t2 and (t4 and t3 xor t5 xor t7) xor t4 and t1 xor t3 and t0 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9] + $2AF26013; + temp := (t1 and (t3 and t2 xor t4 xor t6) xor t3 and t0 xor t2 and t7 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[4] + $C5D1B023; + temp := (t0 and (t2 and t1 xor t3 xor t5) xor t2 and t7 xor t1 and t6 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[20] + $286085F0; + temp := (t7 and (t1 and t0 xor t2 xor t4) xor t1 and t6 xor t0 and t5 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28] + $CA417918; + temp := (t6 and (t0 and t7 xor t1 xor t3) xor t0 and t5 xor t7 and t4 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[17] + $B8DB38EF; + temp := (t5 and (t7 and t6 xor t0 xor t2) xor t7 and t4 xor t6 and t3 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[8] + $8E79DCB0; + temp := (t4 and (t6 and t5 xor t7 xor t1) xor t6 and t3 xor t5 and t2 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[22] + $603A180E; + + temp := (t3 and (t5 and t4 xor t6 xor t0) xor t5 and t2 xor t4 and t1 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[29] + $6C9E0E8B; + temp := (t2 and (t4 and t3 xor t5 xor t7) xor t4 and t1 xor t3 and t0 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $B01E8A3E; + temp := (t1 and (t3 and t2 xor t4 xor t6) xor t3 and t0 xor t2 and t7 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[25] + $D71577C1; + temp := (t0 and (t2 and t1 xor t3 xor t5) xor t2 and t7 xor t1 and t6 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[12] + $BD314B27; + temp := (t7 and (t1 and t0 xor t2 xor t4) xor t1 and t6 xor t0 and t5 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[24] + $78AF2FDA; + temp := (t6 and (t0 and t7 xor t1 xor t3) xor t0 and t5 xor t7 and t4 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[30] + $55605C60; + temp := (t5 and (t7 and t6 xor t0 xor t2) xor t7 and t4 xor t6 and t3 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[16] + $E65525F3; + temp := (t4 and (t6 and t5 xor t7 xor t1) xor t6 and t3 xor t5 and t2 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[26] + $AA55AB94; + + temp := (t3 and (t5 and t4 xor t6 xor t0) xor t5 and t2 xor t4 and t1 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[31] + $57489862; + temp := (t2 and (t4 and t3 xor t5 xor t7) xor t4 and t1 xor t3 and t0 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[15] + $63E81440; + temp := (t1 and (t3 and t2 xor t4 xor t6) xor t3 and t0 xor t2 and t7 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[7] + $55CA396A; + temp := (t0 and (t2 and t1 xor t3 xor t5) xor t2 and t7 xor t1 and t6 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3] + $2AAB10B6; + temp := (t7 and (t1 and t0 xor t2 xor t4) xor t1 and t6 xor t0 and t5 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $B4CC5C34; + temp := (t6 and (t0 and t7 xor t1 xor t3) xor t0 and t5 xor t7 and t4 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[0] + $1141E8CE; + temp := (t5 and (t7 and t6 xor t0 xor t2) xor t7 and t4 xor t6 and t3 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[18] + $A15486AF; + temp := (t4 and (t6 and t5 xor t7 xor t1) xor t6 and t3 xor t5 and t2 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $7C72E993; + + temp := (t3 and (t5 and t4 xor t6 xor t0) xor t5 and t2 xor t4 and t1 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[13] + $B3EE1411; + temp := (t2 and (t4 and t3 xor t5 xor t7) xor t4 and t1 xor t3 and t0 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[6] + $636FBC2A; + temp := (t1 and (t3 and t2 xor t4 xor t6) xor t3 and t0 xor t2 and t7 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $2BA9C55D; + temp := (t0 and (t2 and t1 xor t3 xor t5) xor t2 and t7 xor t1 and t6 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[10] + $741831F6; + temp := (t7 and (t1 and t0 xor t2 xor t4) xor t1 and t6 xor t0 and t5 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[23] + $CE5C3E16; + temp := (t6 and (t0 and t7 xor t1 xor t3) xor t0 and t5 xor t7 and t4 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[11] + $9B87931E; + temp := (t5 and (t7 and t6 xor t0 xor t2) xor t7 and t4 xor t6 and t3 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[5] + $AFD6BA33; + temp := (t4 and (t6 and t5 xor t7 xor t1) xor t6 and t3 xor t5 and t2 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[2] + $6C24CF5C; + +{$ELSE} +{$IFDEF PASS4} + // {$INCLUDE DCPhaval4.inc} + temp := (t3 and (t0 xor t1) xor t5 and t6 xor t4 and t2 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0]; + temp := (t2 and (t7 xor t0) xor t4 and t5 xor t3 and t1 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[1]; + temp := (t1 and (t6 xor t7) xor t3 and t4 xor t2 and t0 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[2]; + temp := (t0 and (t5 xor t6) xor t2 and t3 xor t1 and t7 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3]; + temp := (t7 and (t4 xor t5) xor t1 and t2 xor t0 and t6 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[4]; + temp := (t6 and (t3 xor t4) xor t0 and t1 xor t7 and t5 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[5]; + temp := (t5 and (t2 xor t3) xor t7 and t0 xor t6 and t4 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[6]; + temp := (t4 and (t1 xor t2) xor t6 and t7 xor t5 and t3 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[7]; + + temp := (t3 and (t0 xor t1) xor t5 and t6 xor t4 and t2 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[8]; + temp := (t2 and (t7 xor t0) xor t4 and t5 xor t3 and t1 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9]; + temp := (t1 and (t6 xor t7) xor t3 and t4 xor t2 and t0 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[10]; + temp := (t0 and (t5 xor t6) xor t2 and t3 xor t1 and t7 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[11]; + temp := (t7 and (t4 xor t5) xor t1 and t2 xor t0 and t6 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[12]; + temp := (t6 and (t3 xor t4) xor t0 and t1 xor t7 and t5 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[13]; + temp := (t5 and (t2 xor t3) xor t7 and t0 xor t6 and t4 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[14]; + temp := (t4 and (t1 xor t2) xor t6 and t7 xor t5 and t3 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[15]; + + temp := (t3 and (t0 xor t1) xor t5 and t6 xor t4 and t2 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[16]; + temp := (t2 and (t7 xor t0) xor t4 and t5 xor t3 and t1 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[17]; + temp := (t1 and (t6 xor t7) xor t3 and t4 xor t2 and t0 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[18]; + temp := (t0 and (t5 xor t6) xor t2 and t3 xor t1 and t7 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[19]; + temp := (t7 and (t4 xor t5) xor t1 and t2 xor t0 and t6 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[20]; + temp := (t6 and (t3 xor t4) xor t0 and t1 xor t7 and t5 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[21]; + temp := (t5 and (t2 xor t3) xor t7 and t0 xor t6 and t4 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[22]; + temp := (t4 and (t1 xor t2) xor t6 and t7 xor t5 and t3 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[23]; + + temp := (t3 and (t0 xor t1) xor t5 and t6 xor t4 and t2 xor t0); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[24]; + temp := (t2 and (t7 xor t0) xor t4 and t5 xor t3 and t1 xor t7); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[25]; + temp := (t1 and (t6 xor t7) xor t3 and t4 xor t2 and t0 xor t6); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26]; + temp := (t0 and (t5 xor t6) xor t2 and t3 xor t1 and t7 xor t5); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[27]; + temp := (t7 and (t4 xor t5) xor t1 and t2 xor t0 and t6 xor t4); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28]; + temp := (t6 and (t3 xor t4) xor t0 and t1 xor t7 and t5 xor t3); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[29]; + temp := (t5 and (t2 xor t3) xor t7 and t0 xor t6 and t4 xor t2); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[30]; + temp := (t4 and (t1 xor t2) xor t6 and t7 xor t5 and t3 xor t1); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[31]; + + temp := (t1 and (t6 and not t0 xor t2 and t5 xor t3 xor t4) xor t2 and (t6 xor t5) xor t0 and t5 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[5] + $452821E6; + temp := (t0 and (t5 and not t7 xor t1 and t4 xor t2 xor t3) xor t1 and (t5 xor t4) xor t7 and t4 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $38D01377; + temp := (t7 and (t4 and not t6 xor t0 and t3 xor t1 xor t2) xor t0 and (t4 xor t3) xor t6 and t3 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26] + $BE5466CF; + temp := (t6 and (t3 and not t5 xor t7 and t2 xor t0 xor t1) xor t7 and (t3 xor t2) xor t5 and t2 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[18] + $34E90C6C; + temp := (t5 and (t2 and not t4 xor t6 and t1 xor t7 xor t0) xor t6 and (t2 xor t1) xor t4 and t1 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[11] + $C0AC29B7; + temp := (t4 and (t1 and not t3 xor t5 and t0 xor t6 xor t7) xor t5 and (t1 xor t0) xor t3 and t0 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[28] + $C97C50DD; + temp := (t3 and (t0 and not t2 xor t4 and t7 xor t5 xor t6) xor t4 and (t0 xor t7) xor t2 and t7 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[7] + $3F84D5B5; + temp := (t2 and (t7 and not t1 xor t3 and t6 xor t4 xor t5) xor t3 and (t7 xor t6) xor t1 and t6 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[16] + $B5470917; + + temp := (t1 and (t6 and not t0 xor t2 and t5 xor t3 xor t4) xor t2 and (t6 xor t5) xor t0 and t5 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0] + $9216D5D9; + temp := (t0 and (t5 and not t7 xor t1 and t4 xor t2 xor t3) xor t1 and (t5 xor t4) xor t7 and t4 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[23] + $8979FB1B; + temp := (t7 and (t4 and not t6 xor t0 and t3 xor t1 xor t2) xor t0 and (t4 xor t3) xor t6 and t3 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[20] + $D1310BA6; + temp := (t6 and (t3 and not t5 xor t7 and t2 xor t0 xor t1) xor t7 and (t3 xor t2) xor t5 and t2 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[22] + $98DFB5AC; + temp := (t5 and (t2 and not t4 xor t6 and t1 xor t7 xor t0) xor t6 and (t2 xor t1) xor t4 and t1 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $2FFD72DB; + temp := (t4 and (t1 and not t3 xor t5 and t0 xor t6 xor t7) xor t5 and (t1 xor t0) xor t3 and t0 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[10] + $D01ADFB7; + temp := (t3 and (t0 and not t2 xor t4 and t7 xor t5 xor t6) xor t4 and (t0 xor t7) xor t2 and t7 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[4] + $B8E1AFED; + temp := (t2 and (t7 and not t1 xor t3 and t6 xor t4 xor t5) xor t3 and (t7 xor t6) xor t1 and t6 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[8] + $6A267E96; + + temp := (t1 and (t6 and not t0 xor t2 and t5 xor t3 xor t4) xor t2 and (t6 xor t5) xor t0 and t5 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[30] + $BA7C9045; + temp := (t0 and (t5 and not t7 xor t1 and t4 xor t2 xor t3) xor t1 and (t5 xor t4) xor t7 and t4 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[3] + $F12C7F99; + temp := (t7 and (t4 and not t6 xor t0 and t3 xor t1 xor t2) xor t0 and (t4 xor t3) xor t6 and t3 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $24A19947; + temp := (t6 and (t3 and not t5 xor t7 and t2 xor t0 xor t1) xor t7 and (t3 xor t2) xor t5 and t2 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[9] + $B3916CF7; + temp := (t5 and (t2 and not t4 xor t6 and t1 xor t7 xor t0) xor t6 and (t2 xor t1) xor t4 and t1 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $0801F2E2; + temp := (t4 and (t1 and not t3 xor t5 and t0 xor t6 xor t7) xor t5 and (t1 xor t0) xor t3 and t0 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[24] + $858EFC16; + temp := (t3 and (t0 and not t2 xor t4 and t7 xor t5 xor t6) xor t4 and (t0 xor t7) xor t2 and t7 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[29] + $636920D8; + temp := (t2 and (t7 and not t1 xor t3 and t6 xor t4 xor t5) xor t3 and (t7 xor t6) xor t1 and t6 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[6] + $71574E69; + + temp := (t1 and (t6 and not t0 xor t2 and t5 xor t3 xor t4) xor t2 and (t6 xor t5) xor t0 and t5 xor t4); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $A458FEA3; + temp := (t0 and (t5 and not t7 xor t1 and t4 xor t2 xor t3) xor t1 and (t5 xor t4) xor t7 and t4 xor t3); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[12] + $F4933D7E; + temp := (t7 and (t4 and not t6 xor t0 and t3 xor t1 xor t2) xor t0 and (t4 xor t3) xor t6 and t3 xor t2); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[15] + $0D95748F; + temp := (t6 and (t3 and not t5 xor t7 and t2 xor t0 xor t1) xor t7 and (t3 xor t2) xor t5 and t2 xor t1); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[13] + $728EB658; + temp := (t5 and (t2 and not t4 xor t6 and t1 xor t7 xor t0) xor t6 and (t2 xor t1) xor t4 and t1 xor t0); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[2] + $718BCD58; + temp := (t4 and (t1 and not t3 xor t5 and t0 xor t6 xor t7) xor t5 and (t1 xor t0) xor t3 and t0 xor t7); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[25] + $82154AEE; + temp := (t3 and (t0 and not t2 xor t4 and t7 xor t5 xor t6) xor t4 and (t0 xor t7) xor t2 and t7 xor t6); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[31] + $7B54A41D; + temp := (t2 and (t7 and not t1 xor t3 and t6 xor t4 xor t5) xor t3 and (t7 xor t6) xor t1 and t6 xor t5); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $C25A59B5; + + temp := (t6 and (t2 and t0 xor t1 xor t5) xor t2 and t3 xor t0 and t4 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $9C30D539; + temp := (t5 and (t1 and t7 xor t0 xor t4) xor t1 and t2 xor t7 and t3 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9] + $2AF26013; + temp := (t4 and (t0 and t6 xor t7 xor t3) xor t0 and t1 xor t6 and t2 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[4] + $C5D1B023; + temp := (t3 and (t7 and t5 xor t6 xor t2) xor t7 and t0 xor t5 and t1 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[20] + $286085F0; + temp := (t2 and (t6 and t4 xor t5 xor t1) xor t6 and t7 xor t4 and t0 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28] + $CA417918; + temp := (t1 and (t5 and t3 xor t4 xor t0) xor t5 and t6 xor t3 and t7 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[17] + $B8DB38EF; + temp := (t0 and (t4 and t2 xor t3 xor t7) xor t4 and t5 xor t2 and t6 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[8] + $8E79DCB0; + temp := (t7 and (t3 and t1 xor t2 xor t6) xor t3 and t4 xor t1 and t5 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[22] + $603A180E; + + temp := (t6 and (t2 and t0 xor t1 xor t5) xor t2 and t3 xor t0 and t4 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[29] + $6C9E0E8B; + temp := (t5 and (t1 and t7 xor t0 xor t4) xor t1 and t2 xor t7 and t3 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $B01E8A3E; + temp := (t4 and (t0 and t6 xor t7 xor t3) xor t0 and t1 xor t6 and t2 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[25] + $D71577C1; + temp := (t3 and (t7 and t5 xor t6 xor t2) xor t7 and t0 xor t5 and t1 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[12] + $BD314B27; + temp := (t2 and (t6 and t4 xor t5 xor t1) xor t6 and t7 xor t4 and t0 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[24] + $78AF2FDA; + temp := (t1 and (t5 and t3 xor t4 xor t0) xor t5 and t6 xor t3 and t7 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[30] + $55605C60; + temp := (t0 and (t4 and t2 xor t3 xor t7) xor t4 and t5 xor t2 and t6 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[16] + $E65525F3; + temp := (t7 and (t3 and t1 xor t2 xor t6) xor t3 and t4 xor t1 and t5 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[26] + $AA55AB94; + + temp := (t6 and (t2 and t0 xor t1 xor t5) xor t2 and t3 xor t0 and t4 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[31] + $57489862; + temp := (t5 and (t1 and t7 xor t0 xor t4) xor t1 and t2 xor t7 and t3 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[15] + $63E81440; + temp := (t4 and (t0 and t6 xor t7 xor t3) xor t0 and t1 xor t6 and t2 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[7] + $55CA396A; + temp := (t3 and (t7 and t5 xor t6 xor t2) xor t7 and t0 xor t5 and t1 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3] + $2AAB10B6; + temp := (t2 and (t6 and t4 xor t5 xor t1) xor t6 and t7 xor t4 and t0 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $B4CC5C34; + temp := (t1 and (t5 and t3 xor t4 xor t0) xor t5 and t6 xor t3 and t7 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[0] + $1141E8CE; + temp := (t0 and (t4 and t2 xor t3 xor t7) xor t4 and t5 xor t2 and t6 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[18] + $A15486AF; + temp := (t7 and (t3 and t1 xor t2 xor t6) xor t3 and t4 xor t1 and t5 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $7C72E993; + + temp := (t6 and (t2 and t0 xor t1 xor t5) xor t2 and t3 xor t0 and t4 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[13] + $B3EE1411; + temp := (t5 and (t1 and t7 xor t0 xor t4) xor t1 and t2 xor t7 and t3 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[6] + $636FBC2A; + temp := (t4 and (t0 and t6 xor t7 xor t3) xor t0 and t1 xor t6 and t2 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $2BA9C55D; + temp := (t3 and (t7 and t5 xor t6 xor t2) xor t7 and t0 xor t5 and t1 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[10] + $741831F6; + temp := (t2 and (t6 and t4 xor t5 xor t1) xor t6 and t7 xor t4 and t0 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[23] + $CE5C3E16; + temp := (t1 and (t5 and t3 xor t4 xor t0) xor t5 and t6 xor t3 and t7 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[11] + $9B87931E; + temp := (t0 and (t4 and t2 xor t3 xor t7) xor t4 and t5 xor t2 and t6 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[5] + $AFD6BA33; + temp := (t7 and (t3 and t1 xor t2 xor t6) xor t3 and t4 xor t1 and t5 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[2] + $6C24CF5C; + + temp := (t0 and (t4 and not t2 xor t5 and not t6 xor t1 xor t6 xor t3) xor t5 and (t1 and t2 xor t4 xor t6) xor t2 and t6 xor t3); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[24] + $7A325381; + temp := (t7 and (t3 and not t1 xor t4 and not t5 xor t0 xor t5 xor t2) xor t4 and (t0 and t1 xor t3 xor t5) xor t1 and t5 xor t2); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[4] + $28958677; + temp := (t6 and (t2 and not t0 xor t3 and not t4 xor t7 xor t4 xor t1) xor t3 and (t7 and t0 xor t2 xor t4) xor t0 and t4 xor t1); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[0] + $3B8F4898; + temp := (t5 and (t1 and not t7 xor t2 and not t3 xor t6 xor t3 xor t0) xor t2 and (t6 and t7 xor t1 xor t3) xor t7 and t3 xor t0); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[14] + $6B4BB9AF; + temp := (t4 and (t0 and not t6 xor t1 and not t2 xor t5 xor t2 xor t7) xor t1 and (t5 and t6 xor t0 xor t2) xor t6 and t2 xor t7); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[2] + $C4BFE81B; + temp := (t3 and (t7 and not t5 xor t0 and not t1 xor t4 xor t1 xor t6) xor t0 and (t4 and t5 xor t7 xor t1) xor t5 and t1 xor t6); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[7] + $66282193; + temp := (t2 and (t6 and not t4 xor t7 and not t0 xor t3 xor t0 xor t5) xor t7 and (t3 and t4 xor t6 xor t0) xor t4 and t0 xor t5); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[28] + $61D809CC; + temp := (t1 and (t5 and not t3 xor t6 and not t7 xor t2 xor t7 xor t4) xor t6 and (t2 and t3 xor t5 xor t7) xor t3 and t7 xor t4); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[23] + $FB21A991; + + temp := (t0 and (t4 and not t2 xor t5 and not t6 xor t1 xor t6 xor t3) xor t5 and (t1 and t2 xor t4 xor t6) xor t2 and t6 xor t3); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[26] + $487CAC60; + temp := (t7 and (t3 and not t1 xor t4 and not t5 xor t0 xor t5 xor t2) xor t4 and (t0 and t1 xor t3 xor t5) xor t1 and t5 xor t2); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[6] + $5DEC8032; + temp := (t6 and (t2 and not t0 xor t3 and not t4 xor t7 xor t4 xor t1) xor t3 and (t7 and t0 xor t2 xor t4) xor t0 and t4 xor t1); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[30] + $EF845D5D; + temp := (t5 and (t1 and not t7 xor t2 and not t3 xor t6 xor t3 xor t0) xor t2 and (t6 and t7 xor t1 xor t3) xor t7 and t3 xor t0); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[20] + $E98575B1; + temp := (t4 and (t0 and not t6 xor t1 and not t2 xor t5 xor t2 xor t7) xor t1 and (t5 and t6 xor t0 xor t2) xor t6 and t2 xor t7); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[18] + $DC262302; + temp := (t3 and (t7 and not t5 xor t0 and not t1 xor t4 xor t1 xor t6) xor t0 and (t4 and t5 xor t7 xor t1) xor t5 and t1 xor t6); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[25] + $EB651B88; + temp := (t2 and (t6 and not t4 xor t7 and not t0 xor t3 xor t0 xor t5) xor t7 and (t3 and t4 xor t6 xor t0) xor t4 and t0 xor t5); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[19] + $23893E81; + temp := (t1 and (t5 and not t3 xor t6 and not t7 xor t2 xor t7 xor t4) xor t6 and (t2 and t3 xor t5 xor t7) xor t3 and t7 xor t4); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[3] + $D396ACC5; + + temp := (t0 and (t4 and not t2 xor t5 and not t6 xor t1 xor t6 xor t3) xor t5 and (t1 and t2 xor t4 xor t6) xor t2 and t6 xor t3); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[22] + $0F6D6FF3; + temp := (t7 and (t3 and not t1 xor t4 and not t5 xor t0 xor t5 xor t2) xor t4 and (t0 and t1 xor t3 xor t5) xor t1 and t5 xor t2); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[11] + $83F44239; + temp := (t6 and (t2 and not t0 xor t3 and not t4 xor t7 xor t4 xor t1) xor t3 and (t7 and t0 xor t2 xor t4) xor t0 and t4 xor t1); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[31] + $2E0B4482; + temp := (t5 and (t1 and not t7 xor t2 and not t3 xor t6 xor t3 xor t0) xor t2 and (t6 and t7 xor t1 xor t3) xor t7 and t3 xor t0); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[21] + $A4842004; + temp := (t4 and (t0 and not t6 xor t1 and not t2 xor t5 xor t2 xor t7) xor t1 and (t5 and t6 xor t0 xor t2) xor t6 and t2 xor t7); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[8] + $69C8F04A; + temp := (t3 and (t7 and not t5 xor t0 and not t1 xor t4 xor t1 xor t6) xor t0 and (t4 and t5 xor t7 xor t1) xor t5 and t1 xor t6); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[27] + $9E1F9B5E; + temp := (t2 and (t6 and not t4 xor t7 and not t0 xor t3 xor t0 xor t5) xor t7 and (t3 and t4 xor t6 xor t0) xor t4 and t0 xor t5); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[12] + $21C66842; + temp := (t1 and (t5 and not t3 xor t6 and not t7 xor t2 xor t7 xor t4) xor t6 and (t2 and t3 xor t5 xor t7) xor t3 and t7 xor t4); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[9] + $F6E96C9A; + + temp := (t0 and (t4 and not t2 xor t5 and not t6 xor t1 xor t6 xor t3) xor t5 and (t1 and t2 xor t4 xor t6) xor t2 and t6 xor t3); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[1] + $670C9C61; + temp := (t7 and (t3 and not t1 xor t4 and not t5 xor t0 xor t5 xor t2) xor t4 and (t0 and t1 xor t3 xor t5) xor t1 and t5 xor t2); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[29] + $ABD388F0; + temp := (t6 and (t2 and not t0 xor t3 and not t4 xor t7 xor t4 xor t1) xor t3 and (t7 and t0 xor t2 xor t4) xor t0 and t4 xor t1); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[5] + $6A51A0D2; + temp := (t5 and (t1 and not t7 xor t2 and not t3 xor t6 xor t3 xor t0) xor t2 and (t6 and t7 xor t1 xor t3) xor t7 and t3 xor t0); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[15] + $D8542F68; + temp := (t4 and (t0 and not t6 xor t1 and not t2 xor t5 xor t2 xor t7) xor t1 and (t5 and t6 xor t0 xor t2) xor t6 and t2 xor t7); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $960FA728; + temp := (t3 and (t7 and not t5 xor t0 and not t1 xor t4 xor t1 xor t6) xor t0 and (t4 and t5 xor t7 xor t1) xor t5 and t1 xor t6); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[10] + $AB5133A3; + temp := (t2 and (t6 and not t4 xor t7 and not t0 xor t3 xor t0 xor t5) xor t7 and (t3 and t4 xor t6 xor t0) xor t4 and t0 xor t5); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[16] + $6EEF0B6C; + temp := (t1 and (t5 and not t3 xor t6 and not t7 xor t2 xor t7 xor t4) xor t6 and (t2 and t3 xor t5 xor t7) xor t3 and t7 xor t4); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[13] + $137A3BE4; + +{$ELSE} + // {$INCLUDE DCPhaval5.inc} + temp := (t2 and (t6 xor t1) xor t5 and t4 xor t0 and t3 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0]; + temp := (t1 and (t5 xor t0) xor t4 and t3 xor t7 and t2 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[1]; + temp := (t0 and (t4 xor t7) xor t3 and t2 xor t6 and t1 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[2]; + temp := (t7 and (t3 xor t6) xor t2 and t1 xor t5 and t0 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3]; + temp := (t6 and (t2 xor t5) xor t1 and t0 xor t4 and t7 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[4]; + temp := (t5 and (t1 xor t4) xor t0 and t7 xor t3 and t6 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[5]; + temp := (t4 and (t0 xor t3) xor t7 and t6 xor t2 and t5 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[6]; + temp := (t3 and (t7 xor t2) xor t6 and t5 xor t1 and t4 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[7]; + + temp := (t2 and (t6 xor t1) xor t5 and t4 xor t0 and t3 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[8]; + temp := (t1 and (t5 xor t0) xor t4 and t3 xor t7 and t2 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9]; + temp := (t0 and (t4 xor t7) xor t3 and t2 xor t6 and t1 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[10]; + temp := (t7 and (t3 xor t6) xor t2 and t1 xor t5 and t0 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[11]; + temp := (t6 and (t2 xor t5) xor t1 and t0 xor t4 and t7 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[12]; + temp := (t5 and (t1 xor t4) xor t0 and t7 xor t3 and t6 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[13]; + temp := (t4 and (t0 xor t3) xor t7 and t6 xor t2 and t5 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[14]; + temp := (t3 and (t7 xor t2) xor t6 and t5 xor t1 and t4 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[15]; + + temp := (t2 and (t6 xor t1) xor t5 and t4 xor t0 and t3 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[16]; + temp := (t1 and (t5 xor t0) xor t4 and t3 xor t7 and t2 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[17]; + temp := (t0 and (t4 xor t7) xor t3 and t2 xor t6 and t1 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[18]; + temp := (t7 and (t3 xor t6) xor t2 and t1 xor t5 and t0 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[19]; + temp := (t6 and (t2 xor t5) xor t1 and t0 xor t4 and t7 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[20]; + temp := (t5 and (t1 xor t4) xor t0 and t7 xor t3 and t6 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[21]; + temp := (t4 and (t0 xor t3) xor t7 and t6 xor t2 and t5 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[22]; + temp := (t3 and (t7 xor t2) xor t6 and t5 xor t1 and t4 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[23]; + + temp := (t2 and (t6 xor t1) xor t5 and t4 xor t0 and t3 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[24]; + temp := (t1 and (t5 xor t0) xor t4 and t3 xor t7 and t2 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[25]; + temp := (t0 and (t4 xor t7) xor t3 and t2 xor t6 and t1 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26]; + temp := (t7 and (t3 xor t6) xor t2 and t1 xor t5 and t0 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[27]; + temp := (t6 and (t2 xor t5) xor t1 and t0 xor t4 and t7 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28]; + temp := (t5 and (t1 xor t4) xor t0 and t7 xor t3 and t6 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[29]; + temp := (t4 and (t0 xor t3) xor t7 and t6 xor t2 and t5 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[30]; + temp := (t3 and (t7 xor t2) xor t6 and t5 xor t1 and t4 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[31]; + + temp := (t3 and (t4 and not t0 xor t1 and t2 xor t6 xor t5) xor t1 and (t4 xor t2) xor t0 and t2 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[5] + $452821E6; + temp := (t2 and (t3 and not t7 xor t0 and t1 xor t5 xor t4) xor t0 and (t3 xor t1) xor t7 and t1 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $38D01377; + temp := (t1 and (t2 and not t6 xor t7 and t0 xor t4 xor t3) xor t7 and (t2 xor t0) xor t6 and t0 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[26] + $BE5466CF; + temp := (t0 and (t1 and not t5 xor t6 and t7 xor t3 xor t2) xor t6 and (t1 xor t7) xor t5 and t7 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[18] + $34E90C6C; + temp := (t7 and (t0 and not t4 xor t5 and t6 xor t2 xor t1) xor t5 and (t0 xor t6) xor t4 and t6 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[11] + $C0AC29B7; + temp := (t6 and (t7 and not t3 xor t4 and t5 xor t1 xor t0) xor t4 and (t7 xor t5) xor t3 and t5 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[28] + $C97C50DD; + temp := (t5 and (t6 and not t2 xor t3 and t4 xor t0 xor t7) xor t3 and (t6 xor t4) xor t2 and t4 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[7] + $3F84D5B5; + temp := (t4 and (t5 and not t1 xor t2 and t3 xor t7 xor t6) xor t2 and (t5 xor t3) xor t1 and t3 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[16] + $B5470917; + + temp := (t3 and (t4 and not t0 xor t1 and t2 xor t6 xor t5) xor t1 and (t4 xor t2) xor t0 and t2 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[0] + $9216D5D9; + temp := (t2 and (t3 and not t7 xor t0 and t1 xor t5 xor t4) xor t0 and (t3 xor t1) xor t7 and t1 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[23] + $8979FB1B; + temp := (t1 and (t2 and not t6 xor t7 and t0 xor t4 xor t3) xor t7 and (t2 xor t0) xor t6 and t0 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[20] + $D1310BA6; + temp := (t0 and (t1 and not t5 xor t6 and t7 xor t3 xor t2) xor t6 and (t1 xor t7) xor t5 and t7 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[22] + $98DFB5AC; + temp := (t7 and (t0 and not t4 xor t5 and t6 xor t2 xor t1) xor t5 and (t0 xor t6) xor t4 and t6 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $2FFD72DB; + temp := (t6 and (t7 and not t3 xor t4 and t5 xor t1 xor t0) xor t4 and (t7 xor t5) xor t3 and t5 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[10] + $D01ADFB7; + temp := (t5 and (t6 and not t2 xor t3 and t4 xor t0 xor t7) xor t3 and (t6 xor t4) xor t2 and t4 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[4] + $B8E1AFED; + temp := (t4 and (t5 and not t1 xor t2 and t3 xor t7 xor t6) xor t2 and (t5 xor t3) xor t1 and t3 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[8] + $6A267E96; + + temp := (t3 and (t4 and not t0 xor t1 and t2 xor t6 xor t5) xor t1 and (t4 xor t2) xor t0 and t2 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[30] + $BA7C9045; + temp := (t2 and (t3 and not t7 xor t0 and t1 xor t5 xor t4) xor t0 and (t3 xor t1) xor t7 and t1 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[3] + $F12C7F99; + temp := (t1 and (t2 and not t6 xor t7 and t0 xor t4 xor t3) xor t7 and (t2 xor t0) xor t6 and t0 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $24A19947; + temp := (t0 and (t1 and not t5 xor t6 and t7 xor t3 xor t2) xor t6 and (t1 xor t7) xor t5 and t7 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[9] + $B3916CF7; + temp := (t7 and (t0 and not t4 xor t5 and t6 xor t2 xor t1) xor t5 and (t0 xor t6) xor t4 and t6 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $0801F2E2; + temp := (t6 and (t7 and not t3 xor t4 and t5 xor t1 xor t0) xor t4 and (t7 xor t5) xor t3 and t5 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[24] + $858EFC16; + temp := (t5 and (t6 and not t2 xor t3 and t4 xor t0 xor t7) xor t3 and (t6 xor t4) xor t2 and t4 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[29] + $636920D8; + temp := (t4 and (t5 and not t1 xor t2 and t3 xor t7 xor t6) xor t2 and (t5 xor t3) xor t1 and t3 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[6] + $71574E69; + + temp := (t3 and (t4 and not t0 xor t1 and t2 xor t6 xor t5) xor t1 and (t4 xor t2) xor t0 and t2 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $A458FEA3; + temp := (t2 and (t3 and not t7 xor t0 and t1 xor t5 xor t4) xor t0 and (t3 xor t1) xor t7 and t1 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[12] + $F4933D7E; + temp := (t1 and (t2 and not t6 xor t7 and t0 xor t4 xor t3) xor t7 and (t2 xor t0) xor t6 and t0 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[15] + $0D95748F; + temp := (t0 and (t1 and not t5 xor t6 and t7 xor t3 xor t2) xor t6 and (t1 xor t7) xor t5 and t7 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[13] + $728EB658; + temp := (t7 and (t0 and not t4 xor t5 and t6 xor t2 xor t1) xor t5 and (t0 xor t6) xor t4 and t6 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[2] + $718BCD58; + temp := (t6 and (t7 and not t3 xor t4 and t5 xor t1 xor t0) xor t4 and (t7 xor t5) xor t3 and t5 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[25] + $82154AEE; + temp := (t5 and (t6 and not t2 xor t3 and t4 xor t0 xor t7) xor t3 and (t6 xor t4) xor t2 and t4 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[31] + $7B54A41D; + temp := (t4 and (t5 and not t1 xor t2 and t3 xor t7 xor t6) xor t2 and (t5 xor t3) xor t1 and t3 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $C25A59B5; + + temp := (t4 and (t1 and t3 xor t2 xor t5) xor t1 and t0 xor t3 and t6 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $9C30D539; + temp := (t3 and (t0 and t2 xor t1 xor t4) xor t0 and t7 xor t2 and t5 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9] + $2AF26013; + temp := (t2 and (t7 and t1 xor t0 xor t3) xor t7 and t6 xor t1 and t4 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[4] + $C5D1B023; + temp := (t1 and (t6 and t0 xor t7 xor t2) xor t6 and t5 xor t0 and t3 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[20] + $286085F0; + temp := (t0 and (t5 and t7 xor t6 xor t1) xor t5 and t4 xor t7 and t2 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[28] + $CA417918; + temp := (t7 and (t4 and t6 xor t5 xor t0) xor t4 and t3 xor t6 and t1 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[17] + $B8DB38EF; + temp := (t6 and (t3 and t5 xor t4 xor t7) xor t3 and t2 xor t5 and t0 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[8] + $8E79DCB0; + temp := (t5 and (t2 and t4 xor t3 xor t6) xor t2 and t1 xor t4 and t7 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[22] + $603A180E; + + temp := (t4 and (t1 and t3 xor t2 xor t5) xor t1 and t0 xor t3 and t6 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[29] + $6C9E0E8B; + temp := (t3 and (t0 and t2 xor t1 xor t4) xor t0 and t7 xor t2 and t5 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[14] + $B01E8A3E; + temp := (t2 and (t7 and t1 xor t0 xor t3) xor t7 and t6 xor t1 and t4 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[25] + $D71577C1; + temp := (t1 and (t6 and t0 xor t7 xor t2) xor t6 and t5 xor t0 and t3 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[12] + $BD314B27; + temp := (t0 and (t5 and t7 xor t6 xor t1) xor t5 and t4 xor t7 and t2 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[24] + $78AF2FDA; + temp := (t7 and (t4 and t6 xor t5 xor t0) xor t4 and t3 xor t6 and t1 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[30] + $55605C60; + temp := (t6 and (t3 and t5 xor t4 xor t7) xor t3 and t2 xor t5 and t0 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[16] + $E65525F3; + temp := (t5 and (t2 and t4 xor t3 xor t6) xor t2 and t1 xor t4 and t7 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[26] + $AA55AB94; + + temp := (t4 and (t1 and t3 xor t2 xor t5) xor t1 and t0 xor t3 and t6 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[31] + $57489862; + temp := (t3 and (t0 and t2 xor t1 xor t4) xor t0 and t7 xor t2 and t5 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[15] + $63E81440; + temp := (t2 and (t7 and t1 xor t0 xor t3) xor t7 and t6 xor t1 and t4 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[7] + $55CA396A; + temp := (t1 and (t6 and t0 xor t7 xor t2) xor t6 and t5 xor t0 and t3 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[3] + $2AAB10B6; + temp := (t0 and (t5 and t7 xor t6 xor t1) xor t5 and t4 xor t7 and t2 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[1] + $B4CC5C34; + temp := (t7 and (t4 and t6 xor t5 xor t0) xor t4 and t3 xor t6 and t1 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[0] + $1141E8CE; + temp := (t6 and (t3 and t5 xor t4 xor t7) xor t3 and t2 xor t5 and t0 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[18] + $A15486AF; + temp := (t5 and (t2 and t4 xor t3 xor t6) xor t2 and t1 xor t4 and t7 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[27] + $7C72E993; + + temp := (t4 and (t1 and t3 xor t2 xor t5) xor t1 and t0 xor t3 and t6 xor t5); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[13] + $B3EE1411; + temp := (t3 and (t0 and t2 xor t1 xor t4) xor t0 and t7 xor t2 and t5 xor t4); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[6] + $636FBC2A; + temp := (t2 and (t7 and t1 xor t0 xor t3) xor t7 and t6 xor t1 and t4 xor t3); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $2BA9C55D; + temp := (t1 and (t6 and t0 xor t7 xor t2) xor t6 and t5 xor t0 and t3 xor t2); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[10] + $741831F6; + temp := (t0 and (t5 and t7 xor t6 xor t1) xor t5 and t4 xor t7 and t2 xor t1); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[23] + $CE5C3E16; + temp := (t7 and (t4 and t6 xor t5 xor t0) xor t4 and t3 xor t6 and t1 xor t0); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[11] + $9B87931E; + temp := (t6 and (t3 and t5 xor t4 xor t7) xor t3 and t2 xor t5 and t0 xor t7); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[5] + $AFD6BA33; + temp := (t5 and (t2 and t4 xor t3 xor t6) xor t2 and t1 xor t4 and t7 xor t6); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[2] + $6C24CF5C; + + temp := (t3 and (t5 and not t0 xor t2 and not t1 xor t4 xor t1 xor t6) xor t2 and (t4 and t0 xor t5 xor t1) xor t0 and t1 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[24] + $7A325381; + temp := (t2 and (t4 and not t7 xor t1 and not t0 xor t3 xor t0 xor t5) xor t1 and (t3 and t7 xor t4 xor t0) xor t7 and t0 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[4] + $28958677; + temp := (t1 and (t3 and not t6 xor t0 and not t7 xor t2 xor t7 xor t4) xor t0 and (t2 and t6 xor t3 xor t7) xor t6 and t7 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[0] + $3B8F4898; + temp := (t0 and (t2 and not t5 xor t7 and not t6 xor t1 xor t6 xor t3) xor t7 and (t1 and t5 xor t2 xor t6) xor t5 and t6 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[14] + $6B4BB9AF; + temp := (t7 and (t1 and not t4 xor t6 and not t5 xor t0 xor t5 xor t2) xor t6 and (t0 and t4 xor t1 xor t5) xor t4 and t5 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[2] + $C4BFE81B; + temp := (t6 and (t0 and not t3 xor t5 and not t4 xor t7 xor t4 xor t1) xor t5 and (t7 and t3 xor t0 xor t4) xor t3 and t4 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[7] + $66282193; + temp := (t5 and (t7 and not t2 xor t4 and not t3 xor t6 xor t3 xor t0) xor t4 and (t6 and t2 xor t7 xor t3) xor t2 and t3 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[28] + $61D809CC; + temp := (t4 and (t6 and not t1 xor t3 and not t2 xor t5 xor t2 xor t7) xor t3 and (t5 and t1 xor t6 xor t2) xor t1 and t2 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[23] + $FB21A991; + + temp := (t3 and (t5 and not t0 xor t2 and not t1 xor t4 xor t1 xor t6) xor t2 and (t4 and t0 xor t5 xor t1) xor t0 and t1 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[26] + $487CAC60; + temp := (t2 and (t4 and not t7 xor t1 and not t0 xor t3 xor t0 xor t5) xor t1 and (t3 and t7 xor t4 xor t0) xor t7 and t0 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[6] + $5DEC8032; + temp := (t1 and (t3 and not t6 xor t0 and not t7 xor t2 xor t7 xor t4) xor t0 and (t2 and t6 xor t3 xor t7) xor t6 and t7 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[30] + $EF845D5D; + temp := (t0 and (t2 and not t5 xor t7 and not t6 xor t1 xor t6 xor t3) xor t7 and (t1 and t5 xor t2 xor t6) xor t5 and t6 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[20] + $E98575B1; + temp := (t7 and (t1 and not t4 xor t6 and not t5 xor t0 xor t5 xor t2) xor t6 and (t0 and t4 xor t1 xor t5) xor t4 and t5 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[18] + $DC262302; + temp := (t6 and (t0 and not t3 xor t5 and not t4 xor t7 xor t4 xor t1) xor t5 and (t7 and t3 xor t0 xor t4) xor t3 and t4 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[25] + $EB651B88; + temp := (t5 and (t7 and not t2 xor t4 and not t3 xor t6 xor t3 xor t0) xor t4 and (t6 and t2 xor t7 xor t3) xor t2 and t3 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[19] + $23893E81; + temp := (t4 and (t6 and not t1 xor t3 and not t2 xor t5 xor t2 xor t7) xor t3 and (t5 and t1 xor t6 xor t2) xor t1 and t2 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[3] + $D396ACC5; + + temp := (t3 and (t5 and not t0 xor t2 and not t1 xor t4 xor t1 xor t6) xor t2 and (t4 and t0 xor t5 xor t1) xor t0 and t1 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[22] + $0F6D6FF3; + temp := (t2 and (t4 and not t7 xor t1 and not t0 xor t3 xor t0 xor t5) xor t1 and (t3 and t7 xor t4 xor t0) xor t7 and t0 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[11] + $83F44239; + temp := (t1 and (t3 and not t6 xor t0 and not t7 xor t2 xor t7 xor t4) xor t0 and (t2 and t6 xor t3 xor t7) xor t6 and t7 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[31] + $2E0B4482; + temp := (t0 and (t2 and not t5 xor t7 and not t6 xor t1 xor t6 xor t3) xor t7 and (t1 and t5 xor t2 xor t6) xor t5 and t6 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[21] + $A4842004; + temp := (t7 and (t1 and not t4 xor t6 and not t5 xor t0 xor t5 xor t2) xor t6 and (t0 and t4 xor t1 xor t5) xor t4 and t5 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[8] + $69C8F04A; + temp := (t6 and (t0 and not t3 xor t5 and not t4 xor t7 xor t4 xor t1) xor t5 and (t7 and t3 xor t0 xor t4) xor t3 and t4 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[27] + $9E1F9B5E; + temp := (t5 and (t7 and not t2 xor t4 and not t3 xor t6 xor t3 xor t0) xor t4 and (t6 and t2 xor t7 xor t3) xor t2 and t3 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[12] + $21C66842; + temp := (t4 and (t6 and not t1 xor t3 and not t2 xor t5 xor t2 xor t7) xor t3 and (t5 and t1 xor t6 xor t2) xor t1 and t2 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[9] + $F6E96C9A; + + temp := (t3 and (t5 and not t0 xor t2 and not t1 xor t4 xor t1 xor t6) xor t2 and (t4 and t0 xor t5 xor t1) xor t0 and t1 xor t6); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[1] + $670C9C61; + temp := (t2 and (t4 and not t7 xor t1 and not t0 xor t3 xor t0 xor t5) xor t1 and (t3 and t7 xor t4 xor t0) xor t7 and t0 xor t5); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[29] + $ABD388F0; + temp := (t1 and (t3 and not t6 xor t0 and not t7 xor t2 xor t7 xor t4) xor t0 and (t2 and t6 xor t3 xor t7) xor t6 and t7 xor t4); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[5] + $6A51A0D2; + temp := (t0 and (t2 and not t5 xor t7 and not t6 xor t1 xor t6 xor t3) xor t7 and (t1 and t5 xor t2 xor t6) xor t5 and t6 xor t3); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[15] + $D8542F68; + temp := (t7 and (t1 and not t4 xor t6 and not t5 xor t0 xor t5 xor t2) xor t6 and (t0 and t4 xor t1 xor t5) xor t4 and t5 xor t2); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $960FA728; + temp := (t6 and (t0 and not t3 xor t5 and not t4 xor t7 xor t4 xor t1) xor t5 and (t7 and t3 xor t0 xor t4) xor t3 and t4 xor t1); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[10] + $AB5133A3; + temp := (t5 and (t7 and not t2 xor t4 and not t3 xor t6 xor t3 xor t0) xor t4 and (t6 and t2 xor t7 xor t3) xor t2 and t3 xor t0); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[16] + $6EEF0B6C; + temp := (t4 and (t6 and not t1 xor t3 and not t2 xor t5 xor t2 xor t7) xor t3 and (t5 and t1 xor t6 xor t2) xor t1 and t2 xor t7); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[13] + $137A3BE4; + + temp := (t1 and (t3 and t4 and t6 xor not t5) xor t3 and t0 xor t4 and t5 xor t6 and t2); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[27] + $BA3BF050; + temp := (t0 and (t2 and t3 and t5 xor not t4) xor t2 and t7 xor t3 and t4 xor t5 and t1); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[3] + $7EFB2A98; + temp := (t7 and (t1 and t2 and t4 xor not t3) xor t1 and t6 xor t2 and t3 xor t4 and t0); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[21] + $A1F1651D; + temp := (t6 and (t0 and t1 and t3 xor not t2) xor t0 and t5 xor t1 and t2 xor t3 and t7); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[26] + $39AF0176; + temp := (t5 and (t7 and t0 and t2 xor not t1) xor t7 and t4 xor t0 and t1 xor t2 and t6); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[17] + $66CA593E; + temp := (t4 and (t6 and t7 and t1 xor not t0) xor t6 and t3 xor t7 and t0 xor t1 and t5); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[11] + $82430E88; + temp := (t3 and (t5 and t6 and t0 xor not t7) xor t5 and t2 xor t6 and t7 xor t0 and t4); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[20] + $8CEE8619; + temp := (t2 and (t4 and t5 and t7 xor not t6) xor t4 and t1 xor t5 and t6 xor t7 and t3); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[29] + $456F9FB4; + + temp := (t1 and (t3 and t4 and t6 xor not t5) xor t3 and t0 xor t4 and t5 xor t6 and t2); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[19] + $7D84A5C3; + temp := (t0 and (t2 and t3 and t5 xor not t4) xor t2 and t7 xor t3 and t4 xor t5 and t1); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[0] + $3B8B5EBE; + temp := (t7 and (t1 and t2 and t4 xor not t3) xor t1 and t6 xor t2 and t3 xor t4 and t0); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[12] + $E06F75D8; + temp := (t6 and (t0 and t1 and t3 xor not t2) xor t0 and t5 xor t1 and t2 xor t3 and t7); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[7] + $85C12073; + temp := (t5 and (t7 and t0 and t2 xor not t1) xor t7 and t4 xor t0 and t1 xor t2 and t6); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[13] + $401A449F; + temp := (t4 and (t6 and t7 and t1 xor not t0) xor t6 and t3 xor t7 and t0 xor t1 and t5); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[8] + $56C16AA6; + temp := (t3 and (t5 and t6 and t0 xor not t7) xor t5 and t2 xor t6 and t7 xor t0 and t4); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[31] + $4ED3AA62; + temp := (t2 and (t4 and t5 and t7 xor not t6) xor t4 and t1 xor t5 and t6 xor t7 and t3); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[10] + $363F7706; + + temp := (t1 and (t3 and t4 and t6 xor not t5) xor t3 and t0 xor t4 and t5 xor t6 and t2); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[5] + $1BFEDF72; + temp := (t0 and (t2 and t3 and t5 xor not t4) xor t2 and t7 xor t3 and t4 xor t5 and t1); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[9] + $429B023D; + temp := (t7 and (t1 and t2 and t4 xor not t3) xor t1 and t6 xor t2 and t3 xor t4 and t0); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[14] + $37D0D724; + temp := (t6 and (t0 and t1 and t3 xor not t2) xor t0 and t5 xor t1 and t2 xor t3 and t7); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[30] + $D00A1248; + temp := (t5 and (t7 and t0 and t2 xor not t1) xor t7 and t4 xor t0 and t1 xor t2 and t6); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[18] + $DB0FEAD3; + temp := (t4 and (t6 and t7 and t1 xor not t0) xor t6 and t3 xor t7 and t0 xor t1 and t5); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[6] + $49F1C09B; + temp := (t3 and (t5 and t6 and t0 xor not t7) xor t5 and t2 xor t6 and t7 xor t0 and t4); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[28] + $075372C9; + temp := (t2 and (t4 and t5 and t7 xor not t6) xor t4 and t1 xor t5 and t6 xor t7 and t3); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[24] + $80991B7B; + + temp := (t1 and (t3 and t4 and t6 xor not t5) xor t3 and t0 xor t4 and t5 xor t6 and t2); + t7 := ((temp shr 7) or (temp shl 25)) + ((t7 shr 11) or (t7 shl 21)) + w[2] + $25D479D8; + temp := (t0 and (t2 and t3 and t5 xor not t4) xor t2 and t7 xor t3 and t4 xor t5 and t1); + t6 := ((temp shr 7) or (temp shl 25)) + ((t6 shr 11) or (t6 shl 21)) + w[23] + $F6E8DEF7; + temp := (t7 and (t1 and t2 and t4 xor not t3) xor t1 and t6 xor t2 and t3 xor t4 and t0); + t5 := ((temp shr 7) or (temp shl 25)) + ((t5 shr 11) or (t5 shl 21)) + w[16] + $E3FE501A; + temp := (t6 and (t0 and t1 and t3 xor not t2) xor t0 and t5 xor t1 and t2 xor t3 and t7); + t4 := ((temp shr 7) or (temp shl 25)) + ((t4 shr 11) or (t4 shl 21)) + w[22] + $B6794C3B; + temp := (t5 and (t7 and t0 and t2 xor not t1) xor t7 and t4 xor t0 and t1 xor t2 and t6); + t3 := ((temp shr 7) or (temp shl 25)) + ((t3 shr 11) or (t3 shl 21)) + w[4] + $976CE0BD; + temp := (t4 and (t6 and t7 and t1 xor not t0) xor t6 and t3 xor t7 and t0 xor t1 and t5); + t2 := ((temp shr 7) or (temp shl 25)) + ((t2 shr 11) or (t2 shl 21)) + w[1] + $04C006BA; + temp := (t3 and (t5 and t6 and t0 xor not t7) xor t5 and t2 xor t6 and t7 xor t0 and t4); + t1 := ((temp shr 7) or (temp shl 25)) + ((t1 shr 11) or (t1 shl 21)) + w[25] + $C1A94FB6; + temp := (t2 and (t4 and t5 and t7 xor not t6) xor t4 and t1 xor t5 and t6 xor t7 and t3); + t0 := ((temp shr 7) or (temp shl 25)) + ((t0 shr 11) or (t0 shl 21)) + w[15] + $409F60C4; + +{$ENDIF} +{$ENDIF} + + Inc(CurrentHash[0], t0); + Inc(CurrentHash[1], t1); + Inc(CurrentHash[2], t2); + Inc(CurrentHash[3], t3); + Inc(CurrentHash[4], t4); + Inc(CurrentHash[5], t5); + Inc(CurrentHash[6], t6); + Inc(CurrentHash[7], t7); + FillChar(W, Sizeof(W), 0); + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure THAVAL.InitHash; +begin + Burn; + CurrentHash[0] := $243F6A88; + CurrentHash[1] := $85A308D3; + CurrentHash[2] := $13198A2E; + CurrentHash[3] := $03707344; + CurrentHash[4] := $A4093822; + CurrentHash[5] := $299F31D0; + CurrentHash[6] := $082EFA98; + CurrentHash[7] := $EC4E6C89; + fInitialized := true; +end; + +procedure THAVAL.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure THAVAL.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure THAVAL.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure THAVAL.Final(var Digest); +{$IFNDEF DIGEST256} +{$IFNDEF DIGEST224} +var + temp : dword; +{$ENDIF} +{$ENDIF} +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 118 then + Compress; +{$IFDEF PASS3} +{$IFDEF DIGEST128} + HashBuffer[118] := ((128 and 3) shl 6) or (3 shl 3) or 1; + HashBuffer[119] := (128 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST160} + HashBuffer[118] := ((160 and 3) shl 6) or (3 shl 3) or 1; + HashBuffer[119] := (160 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST192} + HashBuffer[118] := ((192 and 3) shl 6) or (3 shl 3) or 1; + HashBuffer[119] := (192 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST224} + HashBuffer[118] := ((224 and 3) shl 6) or (3 shl 3) or 1; + HashBuffer[119] := (224 shr 2) and $FF; +{$ELSE} + HashBuffer[118] := ((256 and 3) shl 6) or (3 shl 3) or 1; + HashBuffer[119] := (256 shr 2) and $FF; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ELSE} +{$IFDEF PASS4} +{$IFDEF DIGEST128} + HashBuffer[118] := ((128 and 3) shl 6) or (4 shl 3) or 1; + HashBuffer[119] := (128 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST160} + HashBuffer[118] := ((160 and 3) shl 6) or (4 shl 3) or 1; + HashBuffer[119] := (160 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST192} + HashBuffer[118] := ((192 and 3) shl 6) or (4 shl 3) or 1; + HashBuffer[119] := (192 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST224} + HashBuffer[118] := ((224 and 3) shl 6) or (4 shl 3) or 1; + HashBuffer[119] := (224 shr 2) and $FF; +{$ELSE} + HashBuffer[118] := ((256 and 3) shl 6) or (4 shl 3) or 1; + HashBuffer[119] := (256 shr 2) and $FF; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ELSE} +{$IFDEF DIGEST128} + HashBuffer[118] := ((128 and 3) shl 6) or (5 shl 3) or 1; + HashBuffer[119] := (2128 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST160} + HashBuffer[118] := ((160 and 3) shl 6) or (5 shl 3) or 1; + HashBuffer[119] := (160 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST192} + HashBuffer[118] := ((192 and 3) shl 6) or (5 shl 3) or 1; + HashBuffer[119] := (192 shr 2) and $FF; +{$ELSE} +{$IFDEF DIGEST224} + HashBuffer[118] := ((224 and 3) shl 6) or (5 shl 3) or 1; + HashBuffer[119] := (224 shr 2) and $FF; +{$ELSE} + HashBuffer[118] := ((256 and 3) shl 6) or (5 shl 3) or 1; + HashBuffer[119] := (256 shr 2) and $FF; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + PDWord(@HashBuffer[120])^ := LenLo; + PDWord(@HashBuffer[124])^ := LenHi; + Compress; +{$IFDEF DIGEST128} + temp := (CurrentHash[7] and $000000FF) or + (CurrentHash[6] and $FF000000) or + (CurrentHash[5] and $00FF0000) or + (CurrentHash[4] and $0000FF00); + Inc(CurrentHash[0], (temp shr 8) or (temp shl 24)); + temp := (CurrentHash[7] and $0000FF00) or + (CurrentHash[6] and $000000FF) or + (CurrentHash[5] and $FF000000) or + (CurrentHash[4] and $00FF0000); + Inc(CurrentHash[1], (temp shr 16) or (temp shl 16)); + temp := (CurrentHash[7] and $00FF0000) or + (CurrentHash[6] and $0000FF00) or + (CurrentHash[5] and $000000FF) or + (CurrentHash[4] and $FF000000); + Inc(CurrentHash[2], (temp shr 24) or (temp shl 8)); + temp := (CurrentHash[7] and $FF000000) or + (CurrentHash[6] and $00FF0000) or + (CurrentHash[5] and $0000FF00) or + (CurrentHash[4] and $000000FF); + Inc(CurrentHash[3], temp); + Move(CurrentHash, Digest, 128 div 8); +{$ELSE} +{$IFDEF DIGEST160} + temp := (CurrentHash[7] and $3F) or + (CurrentHash[6] and ($7F shl 25)) or + (CurrentHash[5] and ($3F shl 19)); + Inc(CurrentHash[0], (temp shr 19) or (temp shl 13)); + temp := (CurrentHash[7] and ($3F shl 6)) or + (CurrentHash[6] and $3F) or + (CurrentHash[5] and ($7F shl 25)); + Inc(CurrentHash[1], (temp shr 25) or (temp shl 7)); + temp := (CurrentHash[7] and ($7F shl 12)) or + (CurrentHash[6] and ($3F shl 6)) or + (CurrentHash[5] and $3F); + Inc(CurrentHash[2], temp); + temp := (CurrentHash[7] and ($3F shl 19)) or + (CurrentHash[6] and ($7F shl 12)) or + (CurrentHash[5] and ($3F shl 6)); + Inc(CurrentHash[3], temp shr 6); + temp := (CurrentHash[7] and ($7F shl 25)) or + (CurrentHash[6] and ($3F shl 19)) or + (CurrentHash[5] and ($7F shl 12)); + Inc(CurrentHash[4], temp shr 12); + Move(CurrentHash, Digest, 160 div 8); +{$ELSE} +{$IFDEF DIGEST192} + temp := (CurrentHash[7] and $1F) or + (CurrentHash[6] and ($3F shl 26)); + Inc(CurrentHash[0], (temp shr 26) or (temp shl 6)); + temp := (CurrentHash[7] and ($1F shl 5)) or + (CurrentHash[6] and $1F); + Inc(CurrentHash[1], temp); + temp := (CurrentHash[7] and ($3F shl 10)) or + (CurrentHash[6] and ($1F shl 5)); + Inc(CurrentHash[2], temp shr 5); + temp := (CurrentHash[7] and ($1F shl 16)) or + (CurrentHash[6] and ($3F shl 10)); + Inc(CurrentHash[3], temp shr 10); + temp := (CurrentHash[7] and ($1F shl 21)) or + (CurrentHash[6] and ($1F shl 16)); + Inc(CurrentHash[4], temp shr 16); + temp := (CurrentHash[7] and ($3F shl 26)) or + (CurrentHash[6] and ($1F shl 21)); + Inc(CurrentHash[5], temp shr 21); + Move(CurrentHash, Digest, 192 div 8); +{$ELSE} +{$IFDEF DIGEST224} + Inc(CurrentHash[0], (CurrentHash[7] shr 27) and $1F); + Inc(CurrentHash[1], (CurrentHash[7] shr 22) and $1F); + Inc(CurrentHash[2], (CurrentHash[7] shr 18) and $F); + Inc(CurrentHash[3], (CurrentHash[7] shr 13) and $1F); + Inc(CurrentHash[4], (CurrentHash[7] shr 9) and $F); + Inc(CurrentHash[5], (CurrentHash[7] shr 4) and $1F); + Inc(CurrentHash[6], CurrentHash[7] and $F); + Move(CurrentHash, Digest, 224 div 8); +{$ELSE} + Move(CurrentHash, Digest, 256 div 8); +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TMD4.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewMD4; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +function LRot32(a, b: longword): longword; +begin + Result := (a shl b) or (a shr (32 - b)); +end; + +procedure TMD4.Compress; +var + Data : array[0..15] of dword; + A, B, C, D : dword; +begin + Move(HashBuffer, Data, Sizeof(Data)); + A := CurrentHash[0]; + B := CurrentHash[1]; + C := CurrentHash[2]; + D := CurrentHash[3]; + + A := LRot32(A + (D xor (B and (C xor D))) + Data[0], 3); + D := LRot32(D + (C xor (A and (B xor C))) + Data[1], 7); + C := LRot32(C + (B xor (D and (A xor B))) + Data[2], 11); + B := LRot32(B + (A xor (C and (D xor A))) + Data[3], 19); + A := LRot32(A + (D xor (B and (C xor D))) + Data[4], 3); + D := LRot32(D + (C xor (A and (B xor C))) + Data[5], 7); + C := LRot32(C + (B xor (D and (A xor B))) + Data[6], 11); + B := LRot32(B + (A xor (C and (D xor A))) + Data[7], 19); + A := LRot32(A + (D xor (B and (C xor D))) + Data[8], 3); + D := LRot32(D + (C xor (A and (B xor C))) + Data[9], 7); + C := LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); + B := LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); + A := LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); + D := LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); + C := LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); + B := LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); + + A := LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[0] + $5A827999, 3); + D := LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[4] + $5A827999, 5); + C := LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[8] + $5A827999, 9); + B := LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + $5A827999, 13); + A := LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[1] + $5A827999, 3); + D := LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[5] + $5A827999, 5); + C := LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[9] + $5A827999, 9); + B := LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + $5A827999, 13); + A := LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[2] + $5A827999, 3); + D := LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[6] + $5A827999, 5); + C := LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + $5A827999, 9); + B := LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + $5A827999, 13); + A := LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[3] + $5A827999, 3); + D := LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[7] + $5A827999, 5); + C := LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + $5A827999, 9); + B := LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + $5A827999, 13); + + A := LRot32(A + (B xor C xor D) + Data[0] + $6ED9EBA1, 3); + D := LRot32(D + (A xor B xor C) + Data[8] + $6ED9EBA1, 9); + C := LRot32(C + (D xor A xor B) + Data[4] + $6ED9EBA1, 11); + B := LRot32(B + (C xor D xor A) + Data[12] + $6ED9EBA1, 15); + A := LRot32(A + (B xor C xor D) + Data[2] + $6ED9EBA1, 3); + D := LRot32(D + (A xor B xor C) + Data[10] + $6ED9EBA1, 9); + C := LRot32(C + (D xor A xor B) + Data[6] + $6ED9EBA1, 11); + B := LRot32(B + (C xor D xor A) + Data[14] + $6ED9EBA1, 15); + A := LRot32(A + (B xor C xor D) + Data[1] + $6ED9EBA1, 3); + D := LRot32(D + (A xor B xor C) + Data[9] + $6ED9EBA1, 9); + C := LRot32(C + (D xor A xor B) + Data[5] + $6ED9EBA1, 11); + B := LRot32(B + (C xor D xor A) + Data[13] + $6ED9EBA1, 15); + A := LRot32(A + (B xor C xor D) + Data[3] + $6ED9EBA1, 3); + D := LRot32(D + (A xor B xor C) + Data[11] + $6ED9EBA1, 9); + C := LRot32(C + (D xor A xor B) + Data[7] + $6ED9EBA1, 11); + B := LRot32(B + (C xor D xor A) + Data[15] + $6ED9EBA1, 15); + + Inc(CurrentHash[0], A); + Inc(CurrentHash[1], B); + Inc(CurrentHash[2], C); + Inc(CurrentHash[3], D); + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TMD4.InitHash; +begin + Burn; + CurrentHash[0] := $67452301; + CurrentHash[1] := $EFCDAB89; + CurrentHash[2] := $98BADCFE; + CurrentHash[3] := $10325476; + fInitialized := true; +end; + +procedure TMD4.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TMD4.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TMD4.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure TMD4.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := LenLo; + PDWord(@HashBuffer[60])^ := LenHi; + Compress; + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TMD5.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewMD5; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TMD5.Compress; +var + Data : array[0..15] of dword; + A, B, C, D : dword; +begin + Move(HashBuffer, Data, Sizeof(Data)); + A := CurrentHash[0]; + B := CurrentHash[1]; + C := CurrentHash[2]; + D := CurrentHash[3]; + + A := B + LRot32(A + (D xor (B and (C xor D))) + Data[0] + $D76AA478, 7); + D := A + LRot32(D + (C xor (A and (B xor C))) + Data[1] + $E8C7B756, 12); + C := D + LRot32(C + (B xor (D and (A xor B))) + Data[2] + $242070DB, 17); + B := C + LRot32(B + (A xor (C and (D xor A))) + Data[3] + $C1BDCEEE, 22); + A := B + LRot32(A + (D xor (B and (C xor D))) + Data[4] + $F57C0FAF, 7); + D := A + LRot32(D + (C xor (A and (B xor C))) + Data[5] + $4787C62A, 12); + C := D + LRot32(C + (B xor (D and (A xor B))) + Data[6] + $A8304613, 17); + B := C + LRot32(B + (A xor (C and (D xor A))) + Data[7] + $FD469501, 22); + A := B + LRot32(A + (D xor (B and (C xor D))) + Data[8] + $698098D8, 7); + D := A + LRot32(D + (C xor (A and (B xor C))) + Data[9] + $8B44F7AF, 12); + C := D + LRot32(C + (B xor (D and (A xor B))) + Data[10] + $FFFF5BB1, 17); + B := C + LRot32(B + (A xor (C and (D xor A))) + Data[11] + $895CD7BE, 22); + A := B + LRot32(A + (D xor (B and (C xor D))) + Data[12] + $6B901122, 7); + D := A + LRot32(D + (C xor (A and (B xor C))) + Data[13] + $FD987193, 12); + C := D + LRot32(C + (B xor (D and (A xor B))) + Data[14] + $A679438E, 17); + B := C + LRot32(B + (A xor (C and (D xor A))) + Data[15] + $49B40821, 22); + + A := B + LRot32(A + (C xor (D and (B xor C))) + Data[1] + $F61E2562, 5); + D := A + LRot32(D + (B xor (C and (A xor B))) + Data[6] + $C040B340, 9); + C := D + LRot32(C + (A xor (B and (D xor A))) + Data[11] + $265E5A51, 14); + B := C + LRot32(B + (D xor (A and (C xor D))) + Data[0] + $E9B6C7AA, 20); + A := B + LRot32(A + (C xor (D and (B xor C))) + Data[5] + $D62F105D, 5); + D := A + LRot32(D + (B xor (C and (A xor B))) + Data[10] + $02441453, 9); + C := D + LRot32(C + (A xor (B and (D xor A))) + Data[15] + $D8A1E681, 14); + B := C + LRot32(B + (D xor (A and (C xor D))) + Data[4] + $E7D3FBC8, 20); + A := B + LRot32(A + (C xor (D and (B xor C))) + Data[9] + $21E1CDE6, 5); + D := A + LRot32(D + (B xor (C and (A xor B))) + Data[14] + $C33707D6, 9); + C := D + LRot32(C + (A xor (B and (D xor A))) + Data[3] + $F4D50D87, 14); + B := C + LRot32(B + (D xor (A and (C xor D))) + Data[8] + $455A14ED, 20); + A := B + LRot32(A + (C xor (D and (B xor C))) + Data[13] + $A9E3E905, 5); + D := A + LRot32(D + (B xor (C and (A xor B))) + Data[2] + $FCEFA3F8, 9); + C := D + LRot32(C + (A xor (B and (D xor A))) + Data[7] + $676F02D9, 14); + B := C + LRot32(B + (D xor (A and (C xor D))) + Data[12] + $8D2A4C8A, 20); + + A := B + LRot32(A + (B xor C xor D) + Data[5] + $FFFA3942, 4); + D := A + LRot32(D + (A xor B xor C) + Data[8] + $8771F681, 11); + C := D + LRot32(C + (D xor A xor B) + Data[11] + $6D9D6122, 16); + B := C + LRot32(B + (C xor D xor A) + Data[14] + $FDE5380C, 23); + A := B + LRot32(A + (B xor C xor D) + Data[1] + $A4BEEA44, 4); + D := A + LRot32(D + (A xor B xor C) + Data[4] + $4BDECFA9, 11); + C := D + LRot32(C + (D xor A xor B) + Data[7] + $F6BB4B60, 16); + B := C + LRot32(B + (C xor D xor A) + Data[10] + $BEBFBC70, 23); + A := B + LRot32(A + (B xor C xor D) + Data[13] + $289B7EC6, 4); + D := A + LRot32(D + (A xor B xor C) + Data[0] + $EAA127FA, 11); + C := D + LRot32(C + (D xor A xor B) + Data[3] + $D4EF3085, 16); + B := C + LRot32(B + (C xor D xor A) + Data[6] + $04881D05, 23); + A := B + LRot32(A + (B xor C xor D) + Data[9] + $D9D4D039, 4); + D := A + LRot32(D + (A xor B xor C) + Data[12] + $E6DB99E5, 11); + C := D + LRot32(C + (D xor A xor B) + Data[15] + $1FA27CF8, 16); + B := C + LRot32(B + (C xor D xor A) + Data[2] + $C4AC5665, 23); + + A := B + LRot32(A + (C xor (B or (not D))) + Data[0] + $F4292244, 6); + D := A + LRot32(D + (B xor (A or (not C))) + Data[7] + $432AFF97, 10); + C := D + LRot32(C + (A xor (D or (not B))) + Data[14] + $AB9423A7, 15); + B := C + LRot32(B + (D xor (C or (not A))) + Data[5] + $FC93A039, 21); + A := B + LRot32(A + (C xor (B or (not D))) + Data[12] + $655B59C3, 6); + D := A + LRot32(D + (B xor (A or (not C))) + Data[3] + $8F0CCC92, 10); + C := D + LRot32(C + (A xor (D or (not B))) + Data[10] + $FFEFF47D, 15); + B := C + LRot32(B + (D xor (C or (not A))) + Data[1] + $85845DD1, 21); + A := B + LRot32(A + (C xor (B or (not D))) + Data[8] + $6FA87E4F, 6); + D := A + LRot32(D + (B xor (A or (not C))) + Data[15] + $FE2CE6E0, 10); + C := D + LRot32(C + (A xor (D or (not B))) + Data[6] + $A3014314, 15); + B := C + LRot32(B + (D xor (C or (not A))) + Data[13] + $4E0811A1, 21); + A := B + LRot32(A + (C xor (B or (not D))) + Data[4] + $F7537E82, 6); + D := A + LRot32(D + (B xor (A or (not C))) + Data[11] + $BD3AF235, 10); + C := D + LRot32(C + (A xor (D or (not B))) + Data[2] + $2AD7D2BB, 15); + B := C + LRot32(B + (D xor (C or (not A))) + Data[9] + $EB86D391, 21); + + Inc(CurrentHash[0], A); + Inc(CurrentHash[1], B); + Inc(CurrentHash[2], C); + Inc(CurrentHash[3], D); + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TMD5.InitHash; +begin + Burn; + CurrentHash[0] := $67452301; + CurrentHash[1] := $EFCDAB89; + CurrentHash[2] := $98BADCFE; + CurrentHash[3] := $10325476; + fInitialized := true; +end; + +procedure TMD5.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TMD5.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TMD5.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure TMD5.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := LenLo; + PDWord(@HashBuffer[60])^ := LenHi; + Compress; + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TRMD128.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewRMD128; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TRMD128.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +{$R-}{$Q-} + +procedure TRMD128.Compress; +var + X : array[0..15] of DWord; + a, aa, b, bb, c, cc, d, dd, t: dword; +begin + Move(HashBuffer, X, Sizeof(X)); + a := CurrentHash[0]; + aa := a; + b := CurrentHash[1]; + bb := b; + c := CurrentHash[2]; + cc := c; + d := CurrentHash[3]; + dd := d; + + t := a + (b xor c xor d) + X[0]; + a := (t shl 11) or (t shr (32 - 11)); + t := d + (a xor b xor c) + X[1]; + d := (t shl 14) or (t shr (32 - 14)); + t := c + (d xor a xor b) + X[2]; + c := (t shl 15) or (t shr (32 - 15)); + t := b + (c xor d xor a) + X[3]; + b := (t shl 12) or (t shr (32 - 12)); + t := a + (b xor c xor d) + X[4]; + a := (t shl 5) or (t shr (32 - 5)); + t := d + (a xor b xor c) + X[5]; + d := (t shl 8) or (t shr (32 - 8)); + t := c + (d xor a xor b) + X[6]; + c := (t shl 7) or (t shr (32 - 7)); + t := b + (c xor d xor a) + X[7]; + b := (t shl 9) or (t shr (32 - 9)); + t := a + (b xor c xor d) + X[8]; + a := (t shl 11) or (t shr (32 - 11)); + t := d + (a xor b xor c) + X[9]; + d := (t shl 13) or (t shr (32 - 13)); + t := c + (d xor a xor b) + X[10]; + c := (t shl 14) or (t shr (32 - 14)); + t := b + (c xor d xor a) + X[11]; + b := (t shl 15) or (t shr (32 - 15)); + t := a + (b xor c xor d) + X[12]; + a := (t shl 6) or (t shr (32 - 6)); + t := d + (a xor b xor c) + X[13]; + d := (t shl 7) or (t shr (32 - 7)); + t := c + (d xor a xor b) + X[14]; + c := (t shl 9) or (t shr (32 - 9)); + t := b + (c xor d xor a) + X[15]; + b := (t shl 8) or (t shr (32 - 8)); + + t := a + ((b and c) or (not b and d)) + X[7] + $5A827999; + a := (t shl 7) or (t shr (32 - 7)); + t := d + ((a and b) or (not a and c)) + X[4] + $5A827999; + d := (t shl 6) or (t shr (32 - 6)); + t := c + ((d and a) or (not d and b)) + X[13] + $5A827999; + c := (t shl 8) or (t shr (32 - 8)); + t := b + ((c and d) or (not c and a)) + X[1] + $5A827999; + b := (t shl 13) or (t shr (32 - 13)); + t := a + ((b and c) or (not b and d)) + X[10] + $5A827999; + a := (t shl 11) or (t shr (32 - 11)); + t := d + ((a and b) or (not a and c)) + X[6] + $5A827999; + d := (t shl 9) or (t shr (32 - 9)); + t := c + ((d and a) or (not d and b)) + X[15] + $5A827999; + c := (t shl 7) or (t shr (32 - 7)); + t := b + ((c and d) or (not c and a)) + X[3] + $5A827999; + b := (t shl 15) or (t shr (32 - 15)); + t := a + ((b and c) or (not b and d)) + X[12] + $5A827999; + a := (t shl 7) or (t shr (32 - 7)); + t := d + ((a and b) or (not a and c)) + X[0] + $5A827999; + d := (t shl 12) or (t shr (32 - 12)); + t := c + ((d and a) or (not d and b)) + X[9] + $5A827999; + c := (t shl 15) or (t shr (32 - 15)); + t := b + ((c and d) or (not c and a)) + X[5] + $5A827999; + b := (t shl 9) or (t shr (32 - 9)); + t := a + ((b and c) or (not b and d)) + X[2] + $5A827999; + a := (t shl 11) or (t shr (32 - 11)); + t := d + ((a and b) or (not a and c)) + X[14] + $5A827999; + d := (t shl 7) or (t shr (32 - 7)); + t := c + ((d and a) or (not d and b)) + X[11] + $5A827999; + c := (t shl 13) or (t shr (32 - 13)); + t := b + ((c and d) or (not c and a)) + X[8] + $5A827999; + b := (t shl 12) or (t shr (32 - 12)); + + t := a + ((b or not c) xor d) + X[3] + $6ED9EBA1; + a := (t shl 11) or (t shr (32 - 11)); + t := d + ((a or not b) xor c) + X[10] + $6ED9EBA1; + d := (t shl 13) or (t shr (32 - 13)); + t := c + ((d or not a) xor b) + X[14] + $6ED9EBA1; + c := (t shl 6) or (t shr (32 - 6)); + t := b + ((c or not d) xor a) + X[4] + $6ED9EBA1; + b := (t shl 7) or (t shr (32 - 7)); + t := a + ((b or not c) xor d) + X[9] + $6ED9EBA1; + a := (t shl 14) or (t shr (32 - 14)); + t := d + ((a or not b) xor c) + X[15] + $6ED9EBA1; + d := (t shl 9) or (t shr (32 - 9)); + t := c + ((d or not a) xor b) + X[8] + $6ED9EBA1; + c := (t shl 13) or (t shr (32 - 13)); + t := b + ((c or not d) xor a) + X[1] + $6ED9EBA1; + b := (t shl 15) or (t shr (32 - 15)); + t := a + ((b or not c) xor d) + X[2] + $6ED9EBA1; + a := (t shl 14) or (t shr (32 - 14)); + t := d + ((a or not b) xor c) + X[7] + $6ED9EBA1; + d := (t shl 8) or (t shr (32 - 8)); + t := c + ((d or not a) xor b) + X[0] + $6ED9EBA1; + c := (t shl 13) or (t shr (32 - 13)); + t := b + ((c or not d) xor a) + X[6] + $6ED9EBA1; + b := (t shl 6) or (t shr (32 - 6)); + t := a + ((b or not c) xor d) + X[13] + $6ED9EBA1; + a := (t shl 5) or (t shr (32 - 5)); + t := d + ((a or not b) xor c) + X[11] + $6ED9EBA1; + d := (t shl 12) or (t shr (32 - 12)); + t := c + ((d or not a) xor b) + X[5] + $6ED9EBA1; + c := (t shl 7) or (t shr (32 - 7)); + t := b + ((c or not d) xor a) + X[12] + $6ED9EBA1; + b := (t shl 5) or (t shr (32 - 5)); + + t := a + ((b and d) or (c and not d)) + X[1] + $8F1BBCDC; + a := (t shl 11) or (t shr (32 - 11)); + t := d + ((a and c) or (b and not c)) + X[9] + $8F1BBCDC; + d := (t shl 12) or (t shr (32 - 12)); + t := c + ((d and b) or (a and not b)) + X[11] + $8F1BBCDC; + c := (t shl 14) or (t shr (32 - 14)); + t := b + ((c and a) or (d and not a)) + X[10] + $8F1BBCDC; + b := (t shl 15) or (t shr (32 - 15)); + t := a + ((b and d) or (c and not d)) + X[0] + $8F1BBCDC; + a := (t shl 14) or (t shr (32 - 14)); + t := d + ((a and c) or (b and not c)) + X[8] + $8F1BBCDC; + d := (t shl 15) or (t shr (32 - 15)); + t := c + ((d and b) or (a and not b)) + X[12] + $8F1BBCDC; + c := (t shl 9) or (t shr (32 - 9)); + t := b + ((c and a) or (d and not a)) + X[4] + $8F1BBCDC; + b := (t shl 8) or (t shr (32 - 8)); + t := a + ((b and d) or (c and not d)) + X[13] + $8F1BBCDC; + a := (t shl 9) or (t shr (32 - 9)); + t := d + ((a and c) or (b and not c)) + X[3] + $8F1BBCDC; + d := (t shl 14) or (t shr (32 - 14)); + t := c + ((d and b) or (a and not b)) + X[7] + $8F1BBCDC; + c := (t shl 5) or (t shr (32 - 5)); + t := b + ((c and a) or (d and not a)) + X[15] + $8F1BBCDC; + b := (t shl 6) or (t shr (32 - 6)); + t := a + ((b and d) or (c and not d)) + X[14] + $8F1BBCDC; + a := (t shl 8) or (t shr (32 - 8)); + t := d + ((a and c) or (b and not c)) + X[5] + $8F1BBCDC; + d := (t shl 6) or (t shr (32 - 6)); + t := c + ((d and b) or (a and not b)) + X[6] + $8F1BBCDC; + c := (t shl 5) or (t shr (32 - 5)); + t := b + ((c and a) or (d and not a)) + X[2] + $8F1BBCDC; + b := (t shl 12) or (t shr (32 - 12)); + + t := aa + ((bb and dd) or (cc and not dd)) + X[5] + $50A28BE6; + aa := (t shl 8) or (t shr (32 - 8)); + t := dd + ((aa and cc) or (bb and not cc)) + X[14] + $50A28BE6; + dd := (t shl 9) or (t shr (32 - 9)); + t := cc + ((dd and bb) or (aa and not bb)) + X[7] + $50A28BE6; + cc := (t shl 9) or (t shr (32 - 9)); + t := bb + ((cc and aa) or (dd and not aa)) + X[0] + $50A28BE6; + bb := (t shl 11) or (t shr (32 - 11)); + t := aa + ((bb and dd) or (cc and not dd)) + X[9] + $50A28BE6; + aa := (t shl 13) or (t shr (32 - 13)); + t := dd + ((aa and cc) or (bb and not cc)) + X[2] + $50A28BE6; + dd := (t shl 15) or (t shr (32 - 15)); + t := cc + ((dd and bb) or (aa and not bb)) + X[11] + $50A28BE6; + cc := (t shl 15) or (t shr (32 - 15)); + t := bb + ((cc and aa) or (dd and not aa)) + X[4] + $50A28BE6; + bb := (t shl 5) or (t shr (32 - 5)); + t := aa + ((bb and dd) or (cc and not dd)) + X[13] + $50A28BE6; + aa := (t shl 7) or (t shr (32 - 7)); + t := dd + ((aa and cc) or (bb and not cc)) + X[6] + $50A28BE6; + dd := (t shl 7) or (t shr (32 - 7)); + t := cc + ((dd and bb) or (aa and not bb)) + X[15] + $50A28BE6; + cc := (t shl 8) or (t shr (32 - 8)); + t := bb + ((cc and aa) or (dd and not aa)) + X[8] + $50A28BE6; + bb := (t shl 11) or (t shr (32 - 11)); + t := aa + ((bb and dd) or (cc and not dd)) + X[1] + $50A28BE6; + aa := (t shl 14) or (t shr (32 - 14)); + t := dd + ((aa and cc) or (bb and not cc)) + X[10] + $50A28BE6; + dd := (t shl 14) or (t shr (32 - 14)); + t := cc + ((dd and bb) or (aa and not bb)) + X[3] + $50A28BE6; + cc := (t shl 12) or (t shr (32 - 12)); + t := bb + ((cc and aa) or (dd and not aa)) + X[12] + $50A28BE6; + bb := (t shl 6) or (t shr (32 - 6)); + + t := aa + ((bb or not cc) xor dd) + X[6] + $5C4DD124; + aa := (t shl 9) or (t shr (32 - 9)); + t := dd + ((aa or not bb) xor cc) + X[11] + $5C4DD124; + dd := (t shl 13) or (t shr (32 - 13)); + t := cc + ((dd or not aa) xor bb) + X[3] + $5C4DD124; + cc := (t shl 15) or (t shr (32 - 15)); + t := bb + ((cc or not dd) xor aa) + X[7] + $5C4DD124; + bb := (t shl 7) or (t shr (32 - 7)); + t := aa + ((bb or not cc) xor dd) + X[0] + $5C4DD124; + aa := (t shl 12) or (t shr (32 - 12)); + t := dd + ((aa or not bb) xor cc) + X[13] + $5C4DD124; + dd := (t shl 8) or (t shr (32 - 8)); + t := cc + ((dd or not aa) xor bb) + X[5] + $5C4DD124; + cc := (t shl 9) or (t shr (32 - 9)); + t := bb + ((cc or not dd) xor aa) + X[10] + $5C4DD124; + bb := (t shl 11) or (t shr (32 - 11)); + t := aa + ((bb or not cc) xor dd) + X[14] + $5C4DD124; + aa := (t shl 7) or (t shr (32 - 7)); + t := dd + ((aa or not bb) xor cc) + X[15] + $5C4DD124; + dd := (t shl 7) or (t shr (32 - 7)); + t := cc + ((dd or not aa) xor bb) + X[8] + $5C4DD124; + cc := (t shl 12) or (t shr (32 - 12)); + t := bb + ((cc or not dd) xor aa) + X[12] + $5C4DD124; + bb := (t shl 7) or (t shr (32 - 7)); + t := aa + ((bb or not cc) xor dd) + X[4] + $5C4DD124; + aa := (t shl 6) or (t shr (32 - 6)); + t := dd + ((aa or not bb) xor cc) + X[9] + $5C4DD124; + dd := (t shl 15) or (t shr (32 - 15)); + t := cc + ((dd or not aa) xor bb) + X[1] + $5C4DD124; + cc := (t shl 13) or (t shr (32 - 13)); + t := bb + ((cc or not dd) xor aa) + X[2] + $5C4DD124; + bb := (t shl 11) or (t shr (32 - 11)); + + t := aa + ((bb and cc) or (not bb and dd)) + X[15] + $6D703EF3; + aa := (t shl 9) or (t shr (32 - 9)); + t := dd + ((aa and bb) or (not aa and cc)) + X[5] + $6D703EF3; + dd := (t shl 7) or (t shr (32 - 7)); + t := cc + ((dd and aa) or (not dd and bb)) + X[1] + $6D703EF3; + cc := (t shl 15) or (t shr (32 - 15)); + t := bb + ((cc and dd) or (not cc and aa)) + X[3] + $6D703EF3; + bb := (t shl 11) or (t shr (32 - 11)); + t := aa + ((bb and cc) or (not bb and dd)) + X[7] + $6D703EF3; + aa := (t shl 8) or (t shr (32 - 8)); + t := dd + ((aa and bb) or (not aa and cc)) + X[14] + $6D703EF3; + dd := (t shl 6) or (t shr (32 - 6)); + t := cc + ((dd and aa) or (not dd and bb)) + X[6] + $6D703EF3; + cc := (t shl 6) or (t shr (32 - 6)); + t := bb + ((cc and dd) or (not cc and aa)) + X[9] + $6D703EF3; + bb := (t shl 14) or (t shr (32 - 14)); + t := aa + ((bb and cc) or (not bb and dd)) + X[11] + $6D703EF3; + aa := (t shl 12) or (t shr (32 - 12)); + t := dd + ((aa and bb) or (not aa and cc)) + X[8] + $6D703EF3; + dd := (t shl 13) or (t shr (32 - 13)); + t := cc + ((dd and aa) or (not dd and bb)) + X[12] + $6D703EF3; + cc := (t shl 5) or (t shr (32 - 5)); + t := bb + ((cc and dd) or (not cc and aa)) + X[2] + $6D703EF3; + bb := (t shl 14) or (t shr (32 - 14)); + t := aa + ((bb and cc) or (not bb and dd)) + X[10] + $6D703EF3; + aa := (t shl 13) or (t shr (32 - 13)); + t := dd + ((aa and bb) or (not aa and cc)) + X[0] + $6D703EF3; + dd := (t shl 13) or (t shr (32 - 13)); + t := cc + ((dd and aa) or (not dd and bb)) + X[4] + $6D703EF3; + cc := (t shl 7) or (t shr (32 - 7)); + t := bb + ((cc and dd) or (not cc and aa)) + X[13] + $6D703EF3; + bb := (t shl 5) or (t shr (32 - 5)); + + t := aa + (bb xor cc xor dd) + X[8]; + aa := (t shl 15) or (t shr (32 - 15)); + t := dd + (aa xor bb xor cc) + X[6]; + dd := (t shl 5) or (t shr (32 - 5)); + t := cc + (dd xor aa xor bb) + X[4]; + cc := (t shl 8) or (t shr (32 - 8)); + t := bb + (cc xor dd xor aa) + X[1]; + bb := (t shl 11) or (t shr (32 - 11)); + t := aa + (bb xor cc xor dd) + X[3]; + aa := (t shl 14) or (t shr (32 - 14)); + t := dd + (aa xor bb xor cc) + X[11]; + dd := (t shl 14) or (t shr (32 - 14)); + t := cc + (dd xor aa xor bb) + X[15]; + cc := (t shl 6) or (t shr (32 - 6)); + t := bb + (cc xor dd xor aa) + X[0]; + bb := (t shl 14) or (t shr (32 - 14)); + t := aa + (bb xor cc xor dd) + X[5]; + aa := (t shl 6) or (t shr (32 - 6)); + t := dd + (aa xor bb xor cc) + X[12]; + dd := (t shl 9) or (t shr (32 - 9)); + t := cc + (dd xor aa xor bb) + X[2]; + cc := (t shl 12) or (t shr (32 - 12)); + t := bb + (cc xor dd xor aa) + X[13]; + bb := (t shl 9) or (t shr (32 - 9)); + t := aa + (bb xor cc xor dd) + X[9]; + aa := (t shl 12) or (t shr (32 - 12)); + t := dd + (aa xor bb xor cc) + X[7]; + dd := (t shl 5) or (t shr (32 - 5)); + t := cc + (dd xor aa xor bb) + X[10]; + cc := (t shl 15) or (t shr (32 - 15)); + t := bb + (cc xor dd xor aa) + X[14]; + bb := (t shl 8) or (t shr (32 - 8)); + + Inc(dd, c + CurrentHash[1]); + CurrentHash[1] := CurrentHash[2] + d + aa; + CurrentHash[2] := CurrentHash[3] + a + bb; + CurrentHash[3] := CurrentHash[0] + b + cc; + CurrentHash[0] := dd; + + FillChar(X, Sizeof(X), 0); + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TRMD128.InitHash; +begin + Burn; + CurrentHash[0] := $67452301; + CurrentHash[1] := $EFCDAB89; + CurrentHash[2] := $98BADCFE; + CurrentHash[3] := $10325476; + fInitialized := true; +end; + +procedure TRMD128.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TRMD128.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TRMD128.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := LenLo; + PDWord(@HashBuffer[60])^ := LenHi; + Compress; + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TRMD160.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewRMD160; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TRMD160.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +{$R-}{$Q-} + +procedure TRMD160.Compress; +var + aa, bb, cc, dd, ee, aaa, bbb, ccc, ddd, eee: DWord; + X : array[0..15] of DWord; +begin + Move(HashBuffer, X, Sizeof(X)); + aa := CurrentHash[0]; + aaa := CurrentHash[0]; + bb := CurrentHash[1]; + bbb := CurrentHash[1]; + cc := CurrentHash[2]; + ccc := CurrentHash[2]; + dd := CurrentHash[3]; + ddd := CurrentHash[3]; + ee := CurrentHash[4]; + eee := CurrentHash[4]; + + aa := aa + (bb xor cc xor dd) + X[0]; + aa := ((aa shl 11) or (aa shr (32 - 11))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor bb xor cc) + X[1]; + ee := ((ee shl 14) or (ee shr (32 - 14))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor aa xor bb) + X[2]; + dd := ((dd shl 15) or (dd shr (32 - 15))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor ee xor aa) + X[3]; + cc := ((cc shl 12) or (cc shr (32 - 12))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor dd xor ee) + X[4]; + bb := ((bb shl 5) or (bb shr (32 - 5))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor cc xor dd) + X[5]; + aa := ((aa shl 8) or (aa shr (32 - 8))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor bb xor cc) + X[6]; + ee := ((ee shl 7) or (ee shr (32 - 7))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor aa xor bb) + X[7]; + dd := ((dd shl 9) or (dd shr (32 - 9))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor ee xor aa) + X[8]; + cc := ((cc shl 11) or (cc shr (32 - 11))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor dd xor ee) + X[9]; + bb := ((bb shl 13) or (bb shr (32 - 13))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor cc xor dd) + X[10]; + aa := ((aa shl 14) or (aa shr (32 - 14))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor bb xor cc) + X[11]; + ee := ((ee shl 15) or (ee shr (32 - 15))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor aa xor bb) + X[12]; + dd := ((dd shl 6) or (dd shr (32 - 6))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor ee xor aa) + X[13]; + cc := ((cc shl 7) or (cc shr (32 - 7))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor dd xor ee) + X[14]; + bb := ((bb shl 9) or (bb shr (32 - 9))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor cc xor dd) + X[15]; + aa := ((aa shl 8) or (aa shr (32 - 8))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + + ee := ee + ((aa and bb) or ((not aa) and cc)) + X[7] + $5A827999; + ee := ((ee shl 7) or (ee shr (32 - 7))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and aa) or ((not ee) and bb)) + X[4] + $5A827999; + dd := ((dd shl 6) or (dd shr (32 - 6))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and ee) or ((not dd) and aa)) + X[13] + $5A827999; + cc := ((cc shl 8) or (cc shr (32 - 8))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and dd) or ((not cc) and ee)) + X[1] + $5A827999; + bb := ((bb shl 13) or (bb shr (32 - 13))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and cc) or ((not bb) and dd)) + X[10] + $5A827999; + aa := ((aa shl 11) or (aa shr (32 - 11))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and bb) or ((not aa) and cc)) + X[6] + $5A827999; + ee := ((ee shl 9) or (ee shr (32 - 9))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and aa) or ((not ee) and bb)) + X[15] + $5A827999; + dd := ((dd shl 7) or (dd shr (32 - 7))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and ee) or ((not dd) and aa)) + X[3] + $5A827999; + cc := ((cc shl 15) or (cc shr (32 - 15))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and dd) or ((not cc) and ee)) + X[12] + $5A827999; + bb := ((bb shl 7) or (bb shr (32 - 7))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and cc) or ((not bb) and dd)) + X[0] + $5A827999; + aa := ((aa shl 12) or (aa shr (32 - 12))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and bb) or ((not aa) and cc)) + X[9] + $5A827999; + ee := ((ee shl 15) or (ee shr (32 - 15))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and aa) or ((not ee) and bb)) + X[5] + $5A827999; + dd := ((dd shl 9) or (dd shr (32 - 9))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and ee) or ((not dd) and aa)) + X[2] + $5A827999; + cc := ((cc shl 11) or (cc shr (32 - 11))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and dd) or ((not cc) and ee)) + X[14] + $5A827999; + bb := ((bb shl 7) or (bb shr (32 - 7))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and cc) or ((not bb) and dd)) + X[11] + $5A827999; + aa := ((aa shl 13) or (aa shr (32 - 13))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and bb) or ((not aa) and cc)) + X[8] + $5A827999; + ee := ((ee shl 12) or (ee shr (32 - 12))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + + dd := dd + ((ee or (not aa)) xor bb) + X[3] + $6ED9EBA1; + dd := ((dd shl 11) or (dd shr (32 - 11))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd or (not ee)) xor aa) + X[10] + $6ED9EBA1; + cc := ((cc shl 13) or (cc shr (32 - 13))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc or (not dd)) xor ee) + X[14] + $6ED9EBA1; + bb := ((bb shl 6) or (bb shr (32 - 6))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb or (not cc)) xor dd) + X[4] + $6ED9EBA1; + aa := ((aa shl 7) or (aa shr (32 - 7))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa or (not bb)) xor cc) + X[9] + $6ED9EBA1; + ee := ((ee shl 14) or (ee shr (32 - 14))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee or (not aa)) xor bb) + X[15] + $6ED9EBA1; + dd := ((dd shl 9) or (dd shr (32 - 9))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd or (not ee)) xor aa) + X[8] + $6ED9EBA1; + cc := ((cc shl 13) or (cc shr (32 - 13))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc or (not dd)) xor ee) + X[1] + $6ED9EBA1; + bb := ((bb shl 15) or (bb shr (32 - 15))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb or (not cc)) xor dd) + X[2] + $6ED9EBA1; + aa := ((aa shl 14) or (aa shr (32 - 14))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa or (not bb)) xor cc) + X[7] + $6ED9EBA1; + ee := ((ee shl 8) or (ee shr (32 - 8))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee or (not aa)) xor bb) + X[0] + $6ED9EBA1; + dd := ((dd shl 13) or (dd shr (32 - 13))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd or (not ee)) xor aa) + X[6] + $6ED9EBA1; + cc := ((cc shl 6) or (cc shr (32 - 6))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc or (not dd)) xor ee) + X[13] + $6ED9EBA1; + bb := ((bb shl 5) or (bb shr (32 - 5))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb or (not cc)) xor dd) + X[11] + $6ED9EBA1; + aa := ((aa shl 12) or (aa shr (32 - 12))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa or (not bb)) xor cc) + X[5] + $6ED9EBA1; + ee := ((ee shl 7) or (ee shr (32 - 7))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee or (not aa)) xor bb) + X[12] + $6ED9EBA1; + dd := ((dd shl 5) or (dd shr (32 - 5))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + + cc := cc + ((dd and aa) or (ee and (not aa))) + X[1] + $8F1BBCDC; + cc := ((cc shl 11) or (cc shr (32 - 11))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and ee) or (dd and (not ee))) + X[9] + $8F1BBCDC; + bb := ((bb shl 12) or (bb shr (32 - 12))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and dd) or (cc and (not dd))) + X[11] + $8F1BBCDC; + aa := ((aa shl 14) or (aa shr (32 - 14))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and cc) or (bb and (not cc))) + X[10] + $8F1BBCDC; + ee := ((ee shl 15) or (ee shr (32 - 15))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and bb) or (aa and (not bb))) + X[0] + $8F1BBCDC; + dd := ((dd shl 14) or (dd shr (32 - 14))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and aa) or (ee and (not aa))) + X[8] + $8F1BBCDC; + cc := ((cc shl 15) or (cc shr (32 - 15))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and ee) or (dd and (not ee))) + X[12] + $8F1BBCDC; + bb := ((bb shl 9) or (bb shr (32 - 9))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and dd) or (cc and (not dd))) + X[4] + $8F1BBCDC; + aa := ((aa shl 8) or (aa shr (32 - 8))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and cc) or (bb and (not cc))) + X[13] + $8F1BBCDC; + ee := ((ee shl 9) or (ee shr (32 - 9))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and bb) or (aa and (not bb))) + X[3] + $8F1BBCDC; + dd := ((dd shl 14) or (dd shr (32 - 14))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and aa) or (ee and (not aa))) + X[7] + $8F1BBCDC; + cc := ((cc shl 5) or (cc shr (32 - 5))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + ((cc and ee) or (dd and (not ee))) + X[15] + $8F1BBCDC; + bb := ((bb shl 6) or (bb shr (32 - 6))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + ((bb and dd) or (cc and (not dd))) + X[14] + $8F1BBCDC; + aa := ((aa shl 8) or (aa shr (32 - 8))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + ((aa and cc) or (bb and (not cc))) + X[5] + $8F1BBCDC; + ee := ((ee shl 6) or (ee shr (32 - 6))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + ((ee and bb) or (aa and (not bb))) + X[6] + $8F1BBCDC; + dd := ((dd shl 5) or (dd shr (32 - 5))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + ((dd and aa) or (ee and (not aa))) + X[2] + $8F1BBCDC; + cc := ((cc shl 12) or (cc shr (32 - 12))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + + bb := bb + (cc xor (dd or (not ee))) + X[4] + $A953FD4E; + bb := ((bb shl 9) or (bb shr (32 - 9))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor (cc or (not dd))) + X[0] + $A953FD4E; + aa := ((aa shl 15) or (aa shr (32 - 15))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor (bb or (not cc))) + X[5] + $A953FD4E; + ee := ((ee shl 5) or (ee shr (32 - 5))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor (aa or (not bb))) + X[9] + $A953FD4E; + dd := ((dd shl 11) or (dd shr (32 - 11))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor (ee or (not aa))) + X[7] + $A953FD4E; + cc := ((cc shl 6) or (cc shr (32 - 6))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor (dd or (not ee))) + X[12] + $A953FD4E; + bb := ((bb shl 8) or (bb shr (32 - 8))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor (cc or (not dd))) + X[2] + $A953FD4E; + aa := ((aa shl 13) or (aa shr (32 - 13))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor (bb or (not cc))) + X[10] + $A953FD4E; + ee := ((ee shl 12) or (ee shr (32 - 12))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor (aa or (not bb))) + X[14] + $A953FD4E; + dd := ((dd shl 5) or (dd shr (32 - 5))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor (ee or (not aa))) + X[1] + $A953FD4E; + cc := ((cc shl 12) or (cc shr (32 - 12))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor (dd or (not ee))) + X[3] + $A953FD4E; + bb := ((bb shl 13) or (bb shr (32 - 13))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + aa := aa + (bb xor (cc or (not dd))) + X[8] + $A953FD4E; + aa := ((aa shl 14) or (aa shr (32 - 14))) + ee; + cc := ((cc shl 10) or (cc shr (32 - 10))); + ee := ee + (aa xor (bb or (not cc))) + X[11] + $A953FD4E; + ee := ((ee shl 11) or (ee shr (32 - 11))) + dd; + bb := ((bb shl 10) or (bb shr (32 - 10))); + dd := dd + (ee xor (aa or (not bb))) + X[6] + $A953FD4E; + dd := ((dd shl 8) or (dd shr (32 - 8))) + cc; + aa := ((aa shl 10) or (aa shr (32 - 10))); + cc := cc + (dd xor (ee or (not aa))) + X[15] + $A953FD4E; + cc := ((cc shl 5) or (cc shr (32 - 5))) + bb; + ee := ((ee shl 10) or (ee shr (32 - 10))); + bb := bb + (cc xor (dd or (not ee))) + X[13] + $A953FD4E; + bb := ((bb shl 6) or (bb shr (32 - 6))) + aa; + dd := ((dd shl 10) or (dd shr (32 - 10))); + + aaa := aaa + (bbb xor (ccc or (not ddd))) + X[5] + $50A28BE6; + aaa := ((aaa shl 8) or (aaa shr (32 - 8))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor (bbb or (not ccc))) + X[14] + $50A28BE6; + eee := ((eee shl 9) or (eee shr (32 - 9))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor (aaa or (not bbb))) + X[7] + $50A28BE6; + ddd := ((ddd shl 9) or (ddd shr (32 - 9))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor (eee or (not aaa))) + X[0] + $50A28BE6; + ccc := ((ccc shl 11) or (ccc shr (32 - 11))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor (ddd or (not eee))) + X[9] + $50A28BE6; + bbb := ((bbb shl 13) or (bbb shr (32 - 13))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor (ccc or (not ddd))) + X[2] + $50A28BE6; + aaa := ((aaa shl 15) or (aaa shr (32 - 15))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor (bbb or (not ccc))) + X[11] + $50A28BE6; + eee := ((eee shl 15) or (eee shr (32 - 15))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor (aaa or (not bbb))) + X[4] + $50A28BE6; + ddd := ((ddd shl 5) or (ddd shr (32 - 5))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor (eee or (not aaa))) + X[13] + $50A28BE6; + ccc := ((ccc shl 7) or (ccc shr (32 - 7))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor (ddd or (not eee))) + X[6] + $50A28BE6; + bbb := ((bbb shl 7) or (bbb shr (32 - 7))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor (ccc or (not ddd))) + X[15] + $50A28BE6; + aaa := ((aaa shl 8) or (aaa shr (32 - 8))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor (bbb or (not ccc))) + X[8] + $50A28BE6; + eee := ((eee shl 11) or (eee shr (32 - 11))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor (aaa or (not bbb))) + X[1] + $50A28BE6; + ddd := ((ddd shl 14) or (ddd shr (32 - 14))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor (eee or (not aaa))) + X[10] + $50A28BE6; + ccc := ((ccc shl 14) or (ccc shr (32 - 14))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor (ddd or (not eee))) + X[3] + $50A28BE6; + bbb := ((bbb shl 12) or (bbb shr (32 - 12))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor (ccc or (not ddd))) + X[12] + $50A28BE6; + aaa := ((aaa shl 6) or (aaa shr (32 - 6))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + + eee := eee + ((aaa and ccc) or (bbb and (not ccc))) + X[6] + $5C4DD124; + eee := ((eee shl 9) or (eee shr (32 - 9))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and bbb) or (aaa and (not bbb))) + X[11] + $5C4DD124; + ddd := ((ddd shl 13) or (ddd shr (32 - 13))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and aaa) or (eee and (not aaa))) + X[3] + $5C4DD124; + ccc := ((ccc shl 15) or (ccc shr (32 - 15))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and eee) or (ddd and (not eee))) + X[7] + $5C4DD124; + bbb := ((bbb shl 7) or (bbb shr (32 - 7))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ddd) or (ccc and (not ddd))) + X[0] + $5C4DD124; + aaa := ((aaa shl 12) or (aaa shr (32 - 12))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and ccc) or (bbb and (not ccc))) + X[13] + $5C4DD124; + eee := ((eee shl 8) or (eee shr (32 - 8))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and bbb) or (aaa and (not bbb))) + X[5] + $5C4DD124; + ddd := ((ddd shl 9) or (ddd shr (32 - 9))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and aaa) or (eee and (not aaa))) + X[10] + $5C4DD124; + ccc := ((ccc shl 11) or (ccc shr (32 - 11))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and eee) or (ddd and (not eee))) + X[14] + $5C4DD124; + bbb := ((bbb shl 7) or (bbb shr (32 - 7))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ddd) or (ccc and (not ddd))) + X[15] + $5C4DD124; + aaa := ((aaa shl 7) or (aaa shr (32 - 7))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and ccc) or (bbb and (not ccc))) + X[8] + $5C4DD124; + eee := ((eee shl 12) or (eee shr (32 - 12))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and bbb) or (aaa and (not bbb))) + X[12] + $5C4DD124; + ddd := ((ddd shl 7) or (ddd shr (32 - 7))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and aaa) or (eee and (not aaa))) + X[4] + $5C4DD124; + ccc := ((ccc shl 6) or (ccc shr (32 - 6))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and eee) or (ddd and (not eee))) + X[9] + $5C4DD124; + bbb := ((bbb shl 15) or (bbb shr (32 - 15))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ddd) or (ccc and (not ddd))) + X[1] + $5C4DD124; + aaa := ((aaa shl 13) or (aaa shr (32 - 13))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and ccc) or (bbb and (not ccc))) + X[2] + $5C4DD124; + eee := ((eee shl 11) or (eee shr (32 - 11))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + + ddd := ddd + ((eee or (not aaa)) xor bbb) + X[15] + $6D703EF3; + ddd := ((ddd shl 9) or (ddd shr (32 - 9))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd or (not eee)) xor aaa) + X[5] + $6D703EF3; + ccc := ((ccc shl 7) or (ccc shr (32 - 7))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc or (not ddd)) xor eee) + X[1] + $6D703EF3; + bbb := ((bbb shl 15) or (bbb shr (32 - 15))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb or (not ccc)) xor ddd) + X[3] + $6D703EF3; + aaa := ((aaa shl 11) or (aaa shr (32 - 11))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa or (not bbb)) xor ccc) + X[7] + $6D703EF3; + eee := ((eee shl 8) or (eee shr (32 - 8))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee or (not aaa)) xor bbb) + X[14] + $6D703EF3; + ddd := ((ddd shl 6) or (ddd shr (32 - 6))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd or (not eee)) xor aaa) + X[6] + $6D703EF3; + ccc := ((ccc shl 6) or (ccc shr (32 - 6))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc or (not ddd)) xor eee) + X[9] + $6D703EF3; + bbb := ((bbb shl 14) or (bbb shr (32 - 14))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb or (not ccc)) xor ddd) + X[11] + $6D703EF3; + aaa := ((aaa shl 12) or (aaa shr (32 - 12))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa or (not bbb)) xor ccc) + X[8] + $6D703EF3; + eee := ((eee shl 13) or (eee shr (32 - 13))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee or (not aaa)) xor bbb) + X[12] + $6D703EF3; + ddd := ((ddd shl 5) or (ddd shr (32 - 5))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd or (not eee)) xor aaa) + X[2] + $6D703EF3; + ccc := ((ccc shl 14) or (ccc shr (32 - 14))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc or (not ddd)) xor eee) + X[10] + $6D703EF3; + bbb := ((bbb shl 13) or (bbb shr (32 - 13))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb or (not ccc)) xor ddd) + X[0] + $6D703EF3; + aaa := ((aaa shl 13) or (aaa shr (32 - 13))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa or (not bbb)) xor ccc) + X[4] + $6D703EF3; + eee := ((eee shl 7) or (eee shr (32 - 7))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee or (not aaa)) xor bbb) + X[13] + $6D703EF3; + ddd := ((ddd shl 5) or (ddd shr (32 - 5))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + + ccc := ccc + ((ddd and eee) or ((not ddd) and aaa)) + X[8] + $7A6D76E9; + ccc := ((ccc shl 15) or (ccc shr (32 - 15))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and ddd) or ((not ccc) and eee)) + X[6] + $7A6D76E9; + bbb := ((bbb shl 5) or (bbb shr (32 - 5))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ccc) or ((not bbb) and ddd)) + X[4] + $7A6D76E9; + aaa := ((aaa shl 8) or (aaa shr (32 - 8))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and bbb) or ((not aaa) and ccc)) + X[1] + $7A6D76E9; + eee := ((eee shl 11) or (eee shr (32 - 11))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and aaa) or ((not eee) and bbb)) + X[3] + $7A6D76E9; + ddd := ((ddd shl 14) or (ddd shr (32 - 14))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and eee) or ((not ddd) and aaa)) + X[11] + $7A6D76E9; + ccc := ((ccc shl 14) or (ccc shr (32 - 14))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and ddd) or ((not ccc) and eee)) + X[15] + $7A6D76E9; + bbb := ((bbb shl 6) or (bbb shr (32 - 6))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ccc) or ((not bbb) and ddd)) + X[0] + $7A6D76E9; + aaa := ((aaa shl 14) or (aaa shr (32 - 14))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and bbb) or ((not aaa) and ccc)) + X[5] + $7A6D76E9; + eee := ((eee shl 6) or (eee shr (32 - 6))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and aaa) or ((not eee) and bbb)) + X[12] + $7A6D76E9; + ddd := ((ddd shl 9) or (ddd shr (32 - 9))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and eee) or ((not ddd) and aaa)) + X[2] + $7A6D76E9; + ccc := ((ccc shl 12) or (ccc shr (32 - 12))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + ((ccc and ddd) or ((not ccc) and eee)) + X[13] + $7A6D76E9; + bbb := ((bbb shl 9) or (bbb shr (32 - 9))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + ((bbb and ccc) or ((not bbb) and ddd)) + X[9] + $7A6D76E9; + aaa := ((aaa shl 12) or (aaa shr (32 - 12))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + ((aaa and bbb) or ((not aaa) and ccc)) + X[7] + $7A6D76E9; + eee := ((eee shl 5) or (eee shr (32 - 5))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + ((eee and aaa) or ((not eee) and bbb)) + X[10] + $7A6D76E9; + ddd := ((ddd shl 15) or (ddd shr (32 - 15))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + ((ddd and eee) or ((not ddd) and aaa)) + X[14] + $7A6D76E9; + ccc := ((ccc shl 8) or (ccc shr (32 - 8))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + + bbb := bbb + (ccc xor ddd xor eee) + X[12]; + bbb := ((bbb shl 8) or (bbb shr (32 - 8))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor ccc xor ddd) + X[15]; + aaa := ((aaa shl 5) or (aaa shr (32 - 5))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor bbb xor ccc) + X[10]; + eee := ((eee shl 12) or (eee shr (32 - 12))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor aaa xor bbb) + X[4]; + ddd := ((ddd shl 9) or (ddd shr (32 - 9))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor eee xor aaa) + X[1]; + ccc := ((ccc shl 12) or (ccc shr (32 - 12))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor ddd xor eee) + X[5]; + bbb := ((bbb shl 5) or (bbb shr (32 - 5))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor ccc xor ddd) + X[8]; + aaa := ((aaa shl 14) or (aaa shr (32 - 14))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor bbb xor ccc) + X[7]; + eee := ((eee shl 6) or (eee shr (32 - 6))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor aaa xor bbb) + X[6]; + ddd := ((ddd shl 8) or (ddd shr (32 - 8))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor eee xor aaa) + X[2]; + ccc := ((ccc shl 13) or (ccc shr (32 - 13))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor ddd xor eee) + X[13]; + bbb := ((bbb shl 6) or (bbb shr (32 - 6))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + aaa := aaa + (bbb xor ccc xor ddd) + X[14]; + aaa := ((aaa shl 5) or (aaa shr (32 - 5))) + eee; + ccc := ((ccc shl 10) or (ccc shr (32 - 10))); + eee := eee + (aaa xor bbb xor ccc) + X[0]; + eee := ((eee shl 15) or (eee shr (32 - 15))) + ddd; + bbb := ((bbb shl 10) or (bbb shr (32 - 10))); + ddd := ddd + (eee xor aaa xor bbb) + X[3]; + ddd := ((ddd shl 13) or (ddd shr (32 - 13))) + ccc; + aaa := ((aaa shl 10) or (aaa shr (32 - 10))); + ccc := ccc + (ddd xor eee xor aaa) + X[9]; + ccc := ((ccc shl 11) or (ccc shr (32 - 11))) + bbb; + eee := ((eee shl 10) or (eee shr (32 - 10))); + bbb := bbb + (ccc xor ddd xor eee) + X[11]; + bbb := ((bbb shl 11) or (bbb shr (32 - 11))) + aaa; + ddd := ((ddd shl 10) or (ddd shr (32 - 10))); + + ddd := ddd + cc + CurrentHash[1]; + CurrentHash[1] := CurrentHash[2] + dd + eee; + CurrentHash[2] := CurrentHash[3] + ee + aaa; + CurrentHash[3] := CurrentHash[4] + aa + bbb; + CurrentHash[4] := CurrentHash[0] + bb + ccc; + CurrentHash[0] := ddd; + FillChar(X, Sizeof(X), 0); + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TRMD160.InitHash; +begin + Burn; + CurrentHash[0] := $67452301; + CurrentHash[1] := $EFCDAB89; + CurrentHash[2] := $98BADCFE; + CurrentHash[3] := $10325476; + CurrentHash[4] := $C3D2E1F0; + fInitialized := true; +end; + +procedure TRMD160.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TRMD160.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TRMD160.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := LenLo; + PDWord(@HashBuffer[60])^ := LenHi; + Compress; + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TSHA1.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewSHA1; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TSHA1.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +{$R-}{$Q-} + +function SwapDWord(a: dword): dword; overload; +begin + Result := ((a and $FF) shl 24) or ((a and $FF00) shl 8) or ((a and $FF0000) shr 8) or ((a and $FF000000) shr 24); +end; + +function SwapDWORD(const a: Int64): Int64; overload; +begin + Result := ((a and $FF) shl 56) or ((a and $FF00) shl 40) or ((a and $FF0000) shl 24) or ((a and $FF000000) shl 8) or + ((a and $FF00000000) shr 8) or ((a and $FF0000000000) shr 24) or ((a and $FF000000000000) shr 40) or ((a and $FF00000000000000) shr 56); +end; + +procedure TSHA1.InitHash; +begin + Burn; + CurrentHash[0] := $67452301; + CurrentHash[1] := $EFCDAB89; + CurrentHash[2] := $98BADCFE; + CurrentHash[3] := $10325476; + CurrentHash[4] := $C3D2E1F0; + fInitialized := true; +end; + +procedure TSHA1.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TSHA1.Compress; +var + A, B, C, D, E : DWord; + W : array[0..79] of DWord; + i : longword; +begin + Index := 0; + Move(HashBuffer, W, Sizeof(HashBuffer)); + for i := 0 to 15 do + W[i] := SwapDWord(W[i]); + for i := 16 to 79 do + W[i] := ((W[i - 3] xor W[i - 8] xor W[i - 14] xor W[i - 16]) shl 1) or ((W[i - 3] xor W[i - 8] xor W[i - 14] xor W[i - 16]) shr 31); + A := CurrentHash[0]; + B := CurrentHash[1]; + C := CurrentHash[2]; + D := CurrentHash[3]; + E := CurrentHash[4]; + + Inc(E, ((A shl 5) or (A shr 27)) + (D xor (B and (C xor D))) + $5A827999 + W[0]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (C xor (A and (B xor C))) + $5A827999 + W[1]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (B xor (E and (A xor B))) + $5A827999 + W[2]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (A xor (D and (E xor A))) + $5A827999 + W[3]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (E xor (C and (D xor E))) + $5A827999 + W[4]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (D xor (B and (C xor D))) + $5A827999 + W[5]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (C xor (A and (B xor C))) + $5A827999 + W[6]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (B xor (E and (A xor B))) + $5A827999 + W[7]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (A xor (D and (E xor A))) + $5A827999 + W[8]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (E xor (C and (D xor E))) + $5A827999 + W[9]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (D xor (B and (C xor D))) + $5A827999 + W[10]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (C xor (A and (B xor C))) + $5A827999 + W[11]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (B xor (E and (A xor B))) + $5A827999 + W[12]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (A xor (D and (E xor A))) + $5A827999 + W[13]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (E xor (C and (D xor E))) + $5A827999 + W[14]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (D xor (B and (C xor D))) + $5A827999 + W[15]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (C xor (A and (B xor C))) + $5A827999 + W[16]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (B xor (E and (A xor B))) + $5A827999 + W[17]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (A xor (D and (E xor A))) + $5A827999 + W[18]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (E xor (C and (D xor E))) + $5A827999 + W[19]); + C := (C shl 30) or (C shr 2); + + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $6ED9EBA1 + W[20]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $6ED9EBA1 + W[21]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $6ED9EBA1 + W[22]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $6ED9EBA1 + W[23]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $6ED9EBA1 + W[24]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $6ED9EBA1 + W[25]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $6ED9EBA1 + W[26]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $6ED9EBA1 + W[27]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $6ED9EBA1 + W[28]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $6ED9EBA1 + W[29]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $6ED9EBA1 + W[30]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $6ED9EBA1 + W[31]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $6ED9EBA1 + W[32]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $6ED9EBA1 + W[33]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $6ED9EBA1 + W[34]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $6ED9EBA1 + W[35]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $6ED9EBA1 + W[36]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $6ED9EBA1 + W[37]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $6ED9EBA1 + W[38]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $6ED9EBA1 + W[39]); + C := (C shl 30) or (C shr 2); + + Inc(E, ((A shl 5) or (A shr 27)) + ((B and C) or (D and (B or C))) + $8F1BBCDC + W[40]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + ((A and B) or (C and (A or B))) + $8F1BBCDC + W[41]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + ((E and A) or (B and (E or A))) + $8F1BBCDC + W[42]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + ((D and E) or (A and (D or E))) + $8F1BBCDC + W[43]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + ((C and D) or (E and (C or D))) + $8F1BBCDC + W[44]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + ((B and C) or (D and (B or C))) + $8F1BBCDC + W[45]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + ((A and B) or (C and (A or B))) + $8F1BBCDC + W[46]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + ((E and A) or (B and (E or A))) + $8F1BBCDC + W[47]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + ((D and E) or (A and (D or E))) + $8F1BBCDC + W[48]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + ((C and D) or (E and (C or D))) + $8F1BBCDC + W[49]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + ((B and C) or (D and (B or C))) + $8F1BBCDC + W[50]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + ((A and B) or (C and (A or B))) + $8F1BBCDC + W[51]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + ((E and A) or (B and (E or A))) + $8F1BBCDC + W[52]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + ((D and E) or (A and (D or E))) + $8F1BBCDC + W[53]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + ((C and D) or (E and (C or D))) + $8F1BBCDC + W[54]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + ((B and C) or (D and (B or C))) + $8F1BBCDC + W[55]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + ((A and B) or (C and (A or B))) + $8F1BBCDC + W[56]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + ((E and A) or (B and (E or A))) + $8F1BBCDC + W[57]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + ((D and E) or (A and (D or E))) + $8F1BBCDC + W[58]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + ((C and D) or (E and (C or D))) + $8F1BBCDC + W[59]); + C := (C shl 30) or (C shr 2); + + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $CA62C1D6 + W[60]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $CA62C1D6 + W[61]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $CA62C1D6 + W[62]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $CA62C1D6 + W[63]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $CA62C1D6 + W[64]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $CA62C1D6 + W[65]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $CA62C1D6 + W[66]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $CA62C1D6 + W[67]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $CA62C1D6 + W[68]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $CA62C1D6 + W[69]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $CA62C1D6 + W[70]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $CA62C1D6 + W[71]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $CA62C1D6 + W[72]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $CA62C1D6 + W[73]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $CA62C1D6 + W[74]); + C := (C shl 30) or (C shr 2); + Inc(E, ((A shl 5) or (A shr 27)) + (B xor C xor D) + $CA62C1D6 + W[75]); + B := (B shl 30) or (B shr 2); + Inc(D, ((E shl 5) or (E shr 27)) + (A xor B xor C) + $CA62C1D6 + W[76]); + A := (A shl 30) or (A shr 2); + Inc(C, ((D shl 5) or (D shr 27)) + (E xor A xor B) + $CA62C1D6 + W[77]); + E := (E shl 30) or (E shr 2); + Inc(B, ((C shl 5) or (C shr 27)) + (D xor E xor A) + $CA62C1D6 + W[78]); + D := (D shl 30) or (D shr 2); + Inc(A, ((B shl 5) or (B shr 27)) + (C xor D xor E) + $CA62C1D6 + W[79]); + C := (C shl 30) or (C shr 2); + + CurrentHash[0] := CurrentHash[0] + A; + CurrentHash[1] := CurrentHash[1] + B; + CurrentHash[2] := CurrentHash[2] + C; + CurrentHash[3] := CurrentHash[3] + D; + CurrentHash[4] := CurrentHash[4] + E; + FillChar(W, Sizeof(W), 0); + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TSHA1.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TSHA1.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := SwapDWord(LenHi); + PDWord(@HashBuffer[60])^ := SwapDWord(LenLo); + Compress; + CurrentHash[0] := SwapDWord(CurrentHash[0]); + CurrentHash[1] := SwapDWord(CurrentHash[1]); + CurrentHash[2] := SwapDWord(CurrentHash[2]); + CurrentHash[3] := SwapDWord(CurrentHash[3]); + CurrentHash[4] := SwapDWord(CurrentHash[4]); + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TSHA256.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewSHA256; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TSHA256.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure TSHA256.Compress; +var + a, b, c, d, e, f, g, h, t1, t2: DWord; + W : array[0..63] of DWord; + i : longword; +begin + Index := 0; + a := CurrentHash[0]; + b := CurrentHash[1]; + c := CurrentHash[2]; + d := CurrentHash[3]; + e := CurrentHash[4]; + f := CurrentHash[5]; + g := CurrentHash[6]; + h := CurrentHash[7]; + Move(HashBuffer, W, Sizeof(HashBuffer)); + for i := 0 to 15 do + W[i] := SwapDWord(W[i]); + for i := 16 to 63 do + W[i] := (((W[i - 2] shr 17) or (W[i - 2] shl 15)) xor ((W[i - 2] shr 19) or (W[i - 2] shl 13)) xor + (W[i - 2] shr 10)) + W[i - 7] + (((W[i - 15] shr 7) or (W[i - 15] shl 25)) xor + ((W[i - 15] shr 18) or (W[i - 15] shl 14)) xor (W[i - 15] shr 3)) + W[i - 16]; + { + Non-optimised version + for i:= 0 to 63 do + begin + t1:= h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + + ((e and f) xor (not e and g)) + K[i] + W[i]; + t2:= (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + + ((a and b) xor (a and c) xor (b and c)); + h:= g; g:= f; f:= e; e:= d + t1; d:= c; c:= b; b:= a; a:= t1 + t2; + end; + } + + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $428A2F98 + W[0]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $71374491 + W[1]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $B5C0FBCF + W[2]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $E9B5DBA5 + W[3]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $3956C25B + W[4]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $59F111F1 + W[5]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $923F82A4 + W[6]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $AB1C5ED5 + W[7]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $D807AA98 + W[8]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $12835B01 + W[9]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $243185BE + W[10]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $550C7DC3 + W[11]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $72BE5D74 + W[12]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $80DEB1FE + W[13]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $9BDC06A7 + W[14]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $C19BF174 + W[15]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $E49B69C1 + W[16]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $EFBE4786 + W[17]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $0FC19DC6 + W[18]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $240CA1CC + W[19]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $2DE92C6F + W[20]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $4A7484AA + W[21]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $5CB0A9DC + W[22]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $76F988DA + W[23]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $983E5152 + W[24]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $A831C66D + W[25]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $B00327C8 + W[26]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $BF597FC7 + W[27]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $C6E00BF3 + W[28]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $D5A79147 + W[29]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $06CA6351 + W[30]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $14292967 + W[31]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $27B70A85 + W[32]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $2E1B2138 + W[33]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $4D2C6DFC + W[34]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $53380D13 + W[35]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $650A7354 + W[36]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $766A0ABB + W[37]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $81C2C92E + W[38]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $92722C85 + W[39]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $A2BFE8A1 + W[40]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $A81A664B + W[41]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $C24B8B70 + W[42]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $C76C51A3 + W[43]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $D192E819 + W[44]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $D6990624 + W[45]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $F40E3585 + W[46]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $106AA070 + W[47]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $19A4C116 + W[48]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $1E376C08 + W[49]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $2748774C + W[50]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $34B0BCB5 + W[51]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $391C0CB3 + W[52]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $4ED8AA4A + W[53]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $5B9CCA4F + W[54]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $682E6FF3 + W[55]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + t1 := h + (((e shr 6) or (e shl 26)) xor ((e shr 11) or (e shl 21)) xor ((e shr 25) or (e shl 7))) + ((e and f) xor (not e and g)) + $748F82EE + W[56]; + t2 := (((a shr 2) or (a shl 30)) xor ((a shr 13) or (a shl 19)) xor ((a shr 22) xor (a shl 10))) + ((a and b) xor (a and c) xor (b and c)); + h := t1 + t2; + d := d + t1; + t1 := g + (((d shr 6) or (d shl 26)) xor ((d shr 11) or (d shl 21)) xor ((d shr 25) or (d shl 7))) + ((d and e) xor (not d and f)) + $78A5636F + W[57]; + t2 := (((h shr 2) or (h shl 30)) xor ((h shr 13) or (h shl 19)) xor ((h shr 22) xor (h shl 10))) + ((h and a) xor (h and b) xor (a and b)); + g := t1 + t2; + c := c + t1; + t1 := f + (((c shr 6) or (c shl 26)) xor ((c shr 11) or (c shl 21)) xor ((c shr 25) or (c shl 7))) + ((c and d) xor (not c and e)) + $84C87814 + W[58]; + t2 := (((g shr 2) or (g shl 30)) xor ((g shr 13) or (g shl 19)) xor ((g shr 22) xor (g shl 10))) + ((g and h) xor (g and a) xor (h and a)); + f := t1 + t2; + b := b + t1; + t1 := e + (((b shr 6) or (b shl 26)) xor ((b shr 11) or (b shl 21)) xor ((b shr 25) or (b shl 7))) + ((b and c) xor (not b and d)) + $8CC70208 + W[59]; + t2 := (((f shr 2) or (f shl 30)) xor ((f shr 13) or (f shl 19)) xor ((f shr 22) xor (f shl 10))) + ((f and g) xor (f and h) xor (g and h)); + e := t1 + t2; + a := a + t1; + t1 := d + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor ((a shr 25) or (a shl 7))) + ((a and b) xor (not a and c)) + $90BEFFFA + W[60]; + t2 := (((e shr 2) or (e shl 30)) xor ((e shr 13) or (e shl 19)) xor ((e shr 22) xor (e shl 10))) + ((e and f) xor (e and g) xor (f and g)); + d := t1 + t2; + h := h + t1; + t1 := c + (((h shr 6) or (h shl 26)) xor ((h shr 11) or (h shl 21)) xor ((h shr 25) or (h shl 7))) + ((h and a) xor (not h and b)) + $A4506CEB + W[61]; + t2 := (((d shr 2) or (d shl 30)) xor ((d shr 13) or (d shl 19)) xor ((d shr 22) xor (d shl 10))) + ((d and e) xor (d and f) xor (e and f)); + c := t1 + t2; + g := g + t1; + t1 := b + (((g shr 6) or (g shl 26)) xor ((g shr 11) or (g shl 21)) xor ((g shr 25) or (g shl 7))) + ((g and h) xor (not g and a)) + $BEF9A3F7 + W[62]; + t2 := (((c shr 2) or (c shl 30)) xor ((c shr 13) or (c shl 19)) xor ((c shr 22) xor (c shl 10))) + ((c and d) xor (c and e) xor (d and e)); + b := t1 + t2; + f := f + t1; + t1 := a + (((f shr 6) or (f shl 26)) xor ((f shr 11) or (f shl 21)) xor ((f shr 25) or (f shl 7))) + ((f and g) xor (not f and h)) + $C67178F2 + W[63]; + t2 := (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor ((b shr 22) xor (b shl 10))) + ((b and c) xor (b and d) xor (c and d)); + a := t1 + t2; + e := e + t1; + + CurrentHash[0] := CurrentHash[0] + a; + CurrentHash[1] := CurrentHash[1] + b; + CurrentHash[2] := CurrentHash[2] + c; + CurrentHash[3] := CurrentHash[3] + d; + CurrentHash[4] := CurrentHash[4] + e; + CurrentHash[5] := CurrentHash[5] + f; + CurrentHash[6] := CurrentHash[6] + g; + CurrentHash[7] := CurrentHash[7] + h; + FillChar(W, Sizeof(W), 0); + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TSHA256.InitHash; +begin + Burn; + CurrentHash[0] := $6A09E667; + CurrentHash[1] := $BB67AE85; + CurrentHash[2] := $3C6EF372; + CurrentHash[3] := $A54FF53A; + CurrentHash[4] := $510E527F; + CurrentHash[5] := $9B05688C; + CurrentHash[6] := $1F83D9AB; + CurrentHash[7] := $5BE0CD19; + fInitialized := true; +end; + +procedure TSHA256.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TSHA256.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + /// if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenHi, Size shr 29); + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TSHA256.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 56 then + Compress; + PDWord(@HashBuffer[56])^ := SwapDWord(LenHi); + PDWord(@HashBuffer[60])^ := SwapDWord(LenLo); + Compress; + CurrentHash[0] := SwapDWord(CurrentHash[0]); + CurrentHash[1] := SwapDWord(CurrentHash[1]); + CurrentHash[2] := SwapDWord(CurrentHash[2]); + CurrentHash[3] := SwapDWord(CurrentHash[3]); + CurrentHash[4] := SwapDWord(CurrentHash[4]); + CurrentHash[5] := SwapDWord(CurrentHash[5]); + CurrentHash[6] := SwapDWord(CurrentHash[6]); + CurrentHash[7] := SwapDWord(CurrentHash[7]); + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TSHA384.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewSHA384; +begin + New(Result, Create); + + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +{$R-}{$Q-} + +procedure TSHA384.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure TSHA384.Compress; +var + a, b, c, d, e, f, g, h, t1, t2: int64; + W : array[0..79] of int64; + i : longword; +begin + Index := 0; + a := CurrentHash[0]; + b := CurrentHash[1]; + c := CurrentHash[2]; + d := CurrentHash[3]; + e := CurrentHash[4]; + f := CurrentHash[5]; + g := CurrentHash[6]; + h := CurrentHash[7]; + Move(HashBuffer, W, Sizeof(HashBuffer)); + for i := 0 to 15 do + W[i] := SwapDWord(W[i]); + for i := 16 to 79 do + W[i] := (((W[i - 2] shr 19) or (W[i - 2] shl 45)) xor ((W[i - 2] shr 61) or (W[i - 2] shl 3)) xor + (W[i - 2] shr 6)) + W[i - 7] + (((W[i - 15] shr 1) or (W[i - 15] shl 63)) xor ((W[i - 15] shr 8) or + (W[i - 15] shl 56)) xor (W[i - 15] shr 7)) + W[i - 16]; + + { + Non-optimised version + for i:= 0 to 79 do + begin + t1:= h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + + ((e and f) xor (not e and g)) + K[i] + W[i]; + t2:= (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + + ((a and b) xor (a and c) xor (b and c)); + h:= g; g:= f; f:= e; e:= d + t1; d:= c; c:= b; b:= a; a:= t1 + t2; + end; + } + + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $428A2F98D728AE22 + W[0]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $7137449123EF65CD + W[1]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $B5C0FBCFEC4D3B2F + W[2]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $E9B5DBA58189DBBC + W[3]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $3956C25BF348B538 + W[4]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $59F111F1B605D019 + W[5]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $923F82A4AF194F9B + W[6]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $AB1C5ED5DA6D8118 + W[7]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $D807AA98A3030242 + W[8]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $12835B0145706FBE + W[9]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $243185BE4EE4B28C + W[10]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $550C7DC3D5FFB4E2 + W[11]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $72BE5D74F27B896F + W[12]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $80DEB1FE3B1696B1 + W[13]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $9BDC06A725C71235 + W[14]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $C19BF174CF692694 + W[15]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $E49B69C19EF14AD2 + W[16]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $EFBE4786384F25E3 + W[17]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $0FC19DC68B8CD5B5 + W[18]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $240CA1CC77AC9C65 + W[19]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $2DE92C6F592B0275 + W[20]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $4A7484AA6EA6E483 + W[21]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5CB0A9DCBD41FBD4 + W[22]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $76F988DA831153B5 + W[23]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $983E5152EE66DFAB + W[24]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $A831C66D2DB43210 + W[25]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $B00327C898FB213F + W[26]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $BF597FC7BEEF0EE4 + W[27]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $C6E00BF33DA88FC2 + W[28]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $D5A79147930AA725 + W[29]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $06CA6351E003826F + W[30]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $142929670A0E6E70 + W[31]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $27B70A8546D22FFC + W[32]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $2E1B21385C26C926 + W[33]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $4D2C6DFC5AC42AED + W[34]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $53380D139D95B3DF + W[35]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $650A73548BAF63DE + W[36]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $766A0ABB3C77B2A8 + W[37]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $81C2C92E47EDAEE6 + W[38]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $92722C851482353B + W[39]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $A2BFE8A14CF10364 + W[40]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $A81A664BBC423001 + W[41]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $C24B8B70D0F89791 + W[42]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $C76C51A30654BE30 + W[43]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $D192E819D6EF5218 + W[44]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $D69906245565A910 + W[45]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $F40E35855771202A + W[46]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $106AA07032BBD1B8 + W[47]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $19A4C116B8D2D0C8 + W[48]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $1E376C085141AB53 + W[49]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $2748774CDF8EEB99 + W[50]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $34B0BCB5E19B48A8 + W[51]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $391C0CB3C5C95A63 + W[52]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $4ED8AA4AE3418ACB + W[53]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5B9CCA4F7763E373 + W[54]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $682E6FF3D6B2B8A3 + W[55]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $748F82EE5DEFB2FC + W[56]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $78A5636F43172F60 + W[57]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $84C87814A1F0AB72 + W[58]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $8CC702081A6439EC + W[59]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $90BEFFFA23631E28 + W[60]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $A4506CEBDE82BDE9 + W[61]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $BEF9A3F7B2C67915 + W[62]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $C67178F2E372532B + W[63]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $CA273ECEEA26619C + W[64]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $D186B8C721C0C207 + W[65]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $EADA7DD6CDE0EB1E + W[66]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $F57D4F7FEE6ED178 + W[67]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $06F067AA72176FBA + W[68]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $0A637DC5A2C898A6 + W[69]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $113F9804BEF90DAE + W[70]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $1B710B35131C471B + W[71]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $28DB77F523047D84 + W[72]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $32CAAB7B40C72493 + W[73]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $3C9EBE0A15C9BEBC + W[74]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $431D67C49C100D4C + W[75]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $4CC5D4BECB3E42B6 + W[76]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $597F299CFC657E2A + W[77]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5FCB6FAB3AD6FAEC + W[78]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $6C44198C4A475817 + W[79]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + + CurrentHash[0] := CurrentHash[0] + a; + CurrentHash[1] := CurrentHash[1] + b; + CurrentHash[2] := CurrentHash[2] + c; + CurrentHash[3] := CurrentHash[3] + d; + CurrentHash[4] := CurrentHash[4] + e; + CurrentHash[5] := CurrentHash[5] + f; + CurrentHash[6] := CurrentHash[6] + g; + CurrentHash[7] := CurrentHash[7] + h; + FillChar(W, Sizeof(W), 0); + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TSHA384.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TSHA384.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then + Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TSHA384.InitHash; +begin + Burn; +{$WARNINGS OFF} + CurrentHash[0] := $CBBB9D5DC1059ED8; + CurrentHash[1] := $629A292A367CD507; + CurrentHash[2] := $9159015A3070DD17; + CurrentHash[3] := $152FECD8F70E5939; + CurrentHash[4] := $67332667FFC00B31; + CurrentHash[5] := $8EB44A8768581511; + CurrentHash[6] := $DB0C2E0D64F98FA7; + CurrentHash[7] := $47B5481DBEFA4FA4; +{$WARNINGS ON} + fInitialized := true; +end; + +procedure TSHA384.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 112 then + Compress; + Pint64(@HashBuffer[112])^ := SwapDWord(LenHi); + Pint64(@HashBuffer[120])^ := SwapDWord(LenLo); + Compress; + CurrentHash[0] := SwapDWord(CurrentHash[0]); + CurrentHash[1] := SwapDWord(CurrentHash[1]); + CurrentHash[2] := SwapDWord(CurrentHash[2]); + CurrentHash[3] := SwapDWord(CurrentHash[3]); + CurrentHash[4] := SwapDWord(CurrentHash[4]); + CurrentHash[5] := SwapDWord(CurrentHash[5]); + Move(CurrentHash, Digest, 384 div 8); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TSHA512.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then Burn; + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewSHA512; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TSHA512.UpdateStr(const s: string); +begin + Update(s[1], Length(s)); +end; + +procedure TSHA512.Compress; +var + a, b, c, d, e, f, g, h, t1, t2: Int64; + W : array[0..79] of Int64; + i : DWORD; +begin + Index := 0; + a := CurrentHash[0]; + b := CurrentHash[1]; + c := CurrentHash[2]; + d := CurrentHash[3]; + e := CurrentHash[4]; + f := CurrentHash[5]; + g := CurrentHash[6]; + h := CurrentHash[7]; + Move(HashBuffer, W, Sizeof(HashBuffer)); + for i := 0 to 15 do W[i] := SwapDWORD(W[i]); + for i := 16 to 79 do + begin + W[i] := (((W[i - 2] shr 19) or (W[i - 2] shl 45)) xor ((W[i - 2] shr 61) or (W[i - 2] shl 3)) xor + (W[i - 2] shr 6)) + W[i - 7] + (((W[i - 15] shr 1) or (W[i - 15] shl 63)) xor ((W[i - 15] shr 8) or (W[i - 15] shl 56)) xor (W[i - 15] shr 7)) + W[i - 16]; + end; + + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $428A2F98D728AE22 + W[0]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $7137449123EF65CD + W[1]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $B5C0FBCFEC4D3B2F + W[2]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $E9B5DBA58189DBBC + W[3]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $3956C25BF348B538 + W[4]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $59F111F1B605D019 + W[5]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $923F82A4AF194F9B + W[6]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $AB1C5ED5DA6D8118 + W[7]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $D807AA98A3030242 + W[8]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $12835B0145706FBE + W[9]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $243185BE4EE4B28C + W[10]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $550C7DC3D5FFB4E2 + W[11]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $72BE5D74F27B896F + W[12]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $80DEB1FE3B1696B1 + W[13]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $9BDC06A725C71235 + W[14]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $C19BF174CF692694 + W[15]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $E49B69C19EF14AD2 + W[16]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $EFBE4786384F25E3 + W[17]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $0FC19DC68B8CD5B5 + W[18]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $240CA1CC77AC9C65 + W[19]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $2DE92C6F592B0275 + W[20]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $4A7484AA6EA6E483 + W[21]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5CB0A9DCBD41FBD4 + W[22]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $76F988DA831153B5 + W[23]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $983E5152EE66DFAB + W[24]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $A831C66D2DB43210 + W[25]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $B00327C898FB213F + W[26]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $BF597FC7BEEF0EE4 + W[27]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $C6E00BF33DA88FC2 + W[28]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $D5A79147930AA725 + W[29]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $06CA6351E003826F + W[30]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $142929670A0E6E70 + W[31]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $27B70A8546D22FFC + W[32]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $2E1B21385C26C926 + W[33]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $4D2C6DFC5AC42AED + W[34]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $53380D139D95B3DF + W[35]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $650A73548BAF63DE + W[36]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $766A0ABB3C77B2A8 + W[37]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $81C2C92E47EDAEE6 + W[38]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $92722C851482353B + W[39]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $A2BFE8A14CF10364 + W[40]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $A81A664BBC423001 + W[41]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $C24B8B70D0F89791 + W[42]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $C76C51A30654BE30 + W[43]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $D192E819D6EF5218 + W[44]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $D69906245565A910 + W[45]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $F40E35855771202A + W[46]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $106AA07032BBD1B8 + W[47]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $19A4C116B8D2D0C8 + W[48]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $1E376C085141AB53 + W[49]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $2748774CDF8EEB99 + W[50]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $34B0BCB5E19B48A8 + W[51]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $391C0CB3C5C95A63 + W[52]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $4ED8AA4AE3418ACB + W[53]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5B9CCA4F7763E373 + W[54]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $682E6FF3D6B2B8A3 + W[55]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $748F82EE5DEFB2FC + W[56]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $78A5636F43172F60 + W[57]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $84C87814A1F0AB72 + W[58]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $8CC702081A6439EC + W[59]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $90BEFFFA23631E28 + W[60]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $A4506CEBDE82BDE9 + W[61]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $BEF9A3F7B2C67915 + W[62]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $C67178F2E372532B + W[63]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $CA273ECEEA26619C + W[64]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $D186B8C721C0C207 + W[65]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $EADA7DD6CDE0EB1E + W[66]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $F57D4F7FEE6ED178 + W[67]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $06F067AA72176FBA + W[68]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $0A637DC5A2C898A6 + W[69]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $113F9804BEF90DAE + W[70]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $1B710B35131C471B + W[71]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + t1 := h + (((e shr 14) or (e shl 50)) xor ((e shr 18) or (e shl 46)) xor ((e shr 41) or (e shl 23))) + ((e and f) xor (not e and g)) + $28DB77F523047D84 + W[72]; + t2 := (((a shr 28) or (a shl 36)) xor ((a shr 34) or (a shl 30)) xor ((a shr 39) or (a shl 25))) + ((a and b) xor (a and c) xor (b and c)); + d := d + t1; + h := t1 + t2; + t1 := g + (((d shr 14) or (d shl 50)) xor ((d shr 18) or (d shl 46)) xor ((d shr 41) or (d shl 23))) + ((d and e) xor (not d and f)) + $32CAAB7B40C72493 + W[73]; + t2 := (((h shr 28) or (h shl 36)) xor ((h shr 34) or (h shl 30)) xor ((h shr 39) or (h shl 25))) + ((h and a) xor (h and b) xor (a and b)); + c := c + t1; + g := t1 + t2; + t1 := f + (((c shr 14) or (c shl 50)) xor ((c shr 18) or (c shl 46)) xor ((c shr 41) or (c shl 23))) + ((c and d) xor (not c and e)) + $3C9EBE0A15C9BEBC + W[74]; + t2 := (((g shr 28) or (g shl 36)) xor ((g shr 34) or (g shl 30)) xor ((g shr 39) or (g shl 25))) + ((g and h) xor (g and a) xor (h and a)); + b := b + t1; + f := t1 + t2; + t1 := e + (((b shr 14) or (b shl 50)) xor ((b shr 18) or (b shl 46)) xor ((b shr 41) or (b shl 23))) + ((b and c) xor (not b and d)) + $431D67C49C100D4C + W[75]; + t2 := (((f shr 28) or (f shl 36)) xor ((f shr 34) or (f shl 30)) xor ((f shr 39) or (f shl 25))) + ((f and g) xor (f and h) xor (g and h)); + a := a + t1; + e := t1 + t2; + t1 := d + (((a shr 14) or (a shl 50)) xor ((a shr 18) or (a shl 46)) xor ((a shr 41) or (a shl 23))) + ((a and b) xor (not a and c)) + $4CC5D4BECB3E42B6 + W[76]; + t2 := (((e shr 28) or (e shl 36)) xor ((e shr 34) or (e shl 30)) xor ((e shr 39) or (e shl 25))) + ((e and f) xor (e and g) xor (f and g)); + h := h + t1; + d := t1 + t2; + t1 := c + (((h shr 14) or (h shl 50)) xor ((h shr 18) or (h shl 46)) xor ((h shr 41) or (h shl 23))) + ((h and a) xor (not h and b)) + $597F299CFC657E2A + W[77]; + t2 := (((d shr 28) or (d shl 36)) xor ((d shr 34) or (d shl 30)) xor ((d shr 39) or (d shl 25))) + ((d and e) xor (d and f) xor (e and f)); + g := g + t1; + c := t1 + t2; + t1 := b + (((g shr 14) or (g shl 50)) xor ((g shr 18) or (g shl 46)) xor ((g shr 41) or (g shl 23))) + ((g and h) xor (not g and a)) + $5FCB6FAB3AD6FAEC + W[78]; + t2 := (((c shr 28) or (c shl 36)) xor ((c shr 34) or (c shl 30)) xor ((c shr 39) or (c shl 25))) + ((c and d) xor (c and e) xor (d and e)); + f := f + t1; + b := t1 + t2; + t1 := a + (((f shr 14) or (f shl 50)) xor ((f shr 18) or (f shl 46)) xor ((f shr 41) or (f shl 23))) + ((f and g) xor (not f and h)) + $6C44198C4A475817 + W[79]; + t2 := (((b shr 28) or (b shl 36)) xor ((b shr 34) or (b shl 30)) xor ((b shr 39) or (b shl 25))) + ((b and c) xor (b and d) xor (c and d)); + e := e + t1; + a := t1 + t2; + + Inc(CurrentHash[0], a); + Inc(CurrentHash[1], b); + Inc(CurrentHash[2], c); + Inc(CurrentHash[3], d); + Inc(CurrentHash[4], e); + Inc(CurrentHash[5], f); + Inc(CurrentHash[6], g); + Inc(CurrentHash[7], h); + FillChar(W, Sizeof(W), 0); + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TSHA512.Burn; +begin + LenHi := 0; + LenLo := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := False; +end; + +procedure TSHA512.Update(const Buffer; Size: DWORD); +var + PBuf : PByte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(LenLo, Size * 8); + if LenLo < (Size * 8) then Inc(LenHi); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWORD(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TSHA512.InitHash; +begin + Burn; +{$WARNINGS OFF} + CurrentHash[0] := $6A09E667F3BCC908; + CurrentHash[1] := $BB67AE8584CAA73B; + CurrentHash[2] := $3C6EF372FE94F82B; + CurrentHash[3] := $A54FF53A5F1D36F1; + CurrentHash[4] := $510E527FADE682D1; + CurrentHash[5] := $9B05688C2B3E6C1F; + CurrentHash[6] := $1F83D9ABFB41BD6B; + CurrentHash[7] := $5BE0CD19137E2179; +{$WARNINGS ON} + fInitialized := True; +end; + +procedure TSHA512.Final(var Digest); +var + i : Integer; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $80; + if Index >= 112 then Compress; + PInt64(@HashBuffer[112])^ := SwapDWORD(LenHi); + PInt64(@HashBuffer[120])^ := SwapDWORD(LenLo); + Compress; + for i := 0 to 7 do CurrentHash[i] := SwapDWORD(CurrentHash[i]); + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +{--------------------} +{ Destructor ОБЪЕКТА } +{--------------------} + +destructor TTIGER.Destroy; +begin + // All Strings := ''; + // Free_And_Nil(All PObj); + if fInitialized then + Burn; + + inherited; +end; +//////////////////////////////////////////////////////////////////////////////// + +{-----------------------------} +{ КОНСТРУКТОР ДЛЯ KOL ОБЪЕКТА } +{-----------------------------} + +function NewTIGER; +begin + New(Result, Create); + //burn; + // code +end; +//////////////////////////////////////////////////////////////////////////////// + +procedure TTIGER.UpdateStr(const Str: string); +begin + Update(Str[1], Length(Str)); +end; + +procedure TTIGER.Compress; +var + a, b, c, aa, bb, cc: int64; + x : array[0..7] of int64; +begin + a := CurrentHash[0]; + aa := a; + b := CurrentHash[1]; + bb := b; + c := CurrentHash[2]; + cc := c; + + Move(HashBuffer, x, Sizeof(x)); + + c := c xor x[0]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 5; + a := a xor x[1]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 5; + b := b xor x[2]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 5; + c := c xor x[3]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 5; + a := a xor x[4]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 5; + b := b xor x[5]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 5; + c := c xor x[6]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 5; + a := a xor x[7]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 5; + x[0] := x[0] - (x[7] xor $A5A5A5A5A5A5A5A5); + x[1] := x[1] xor x[0]; + x[2] := x[2] + x[1]; + x[3] := x[3] - (x[2] xor ((not x[1]) shl 19)); + x[4] := x[4] xor x[3]; + x[5] := x[5] + x[4]; + x[6] := x[6] - (x[5] xor ((not x[4]) shr 23)); + x[7] := x[7] xor x[6]; + x[0] := x[0] + x[7]; + x[1] := x[1] - (x[0] xor ((not x[7]) shl 19)); + x[2] := x[2] xor x[1]; + x[3] := x[3] + x[2]; + x[4] := x[4] - (x[3] xor ((not x[2]) shr 23)); + x[5] := x[5] xor x[4]; + x[6] := x[6] + x[5]; + x[7] := x[7] - (x[6] xor $0123456789ABCDEF); + b := b xor x[0]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 7; + c := c xor x[1]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 7; + a := a xor x[2]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 7; + b := b xor x[3]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 7; + c := c xor x[4]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 7; + a := a xor x[5]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 7; + b := b xor x[6]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 7; + c := c xor x[7]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 7; + x[0] := x[0] - (x[7] xor $A5A5A5A5A5A5A5A5); + x[1] := x[1] xor x[0]; + x[2] := x[2] + x[1]; + x[3] := x[3] - (x[2] xor ((not x[1]) shl 19)); + x[4] := x[4] xor x[3]; + x[5] := x[5] + x[4]; + x[6] := x[6] - (x[5] xor ((not x[4]) shr 23)); + x[7] := x[7] xor x[6]; + x[0] := x[0] + x[7]; + x[1] := x[1] - (x[0] xor ((not x[7]) shl 19)); + x[2] := x[2] xor x[1]; + x[3] := x[3] + x[2]; + x[4] := x[4] - (x[3] xor ((not x[2]) shr 23)); + x[5] := x[5] xor x[4]; + x[6] := x[6] + x[5]; + x[7] := x[7] - (x[6] xor $0123456789ABCDEF); + a := a xor x[0]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 9; + b := b xor x[1]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 9; + c := c xor x[2]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 9; + a := a xor x[3]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 9; + b := b xor x[4]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 9; + c := c xor x[5]; + a := a - (tiger1[c and $FF] xor tiger2[(c shr 16) and $FF] xor tiger3[(c shr 32) and $FF] xor tiger4[(c shr 48) and $FF]); + b := b + (tiger4[(c shr 8) and $FF] xor tiger3[(c shr 24) and $FF] xor tiger2[(c shr 40) and $FF] xor tiger1[(c shr 56) and $FF]); + b := b * 9; + a := a xor x[6]; + b := b - (tiger1[a and $FF] xor tiger2[(a shr 16) and $FF] xor tiger3[(a shr 32) and $FF] xor tiger4[(a shr 48) and $FF]); + c := c + (tiger4[(a shr 8) and $FF] xor tiger3[(a shr 24) and $FF] xor tiger2[(a shr 40) and $FF] xor tiger1[(a shr 56) and $FF]); + c := c * 9; + b := b xor x[7]; + c := c - (tiger1[b and $FF] xor tiger2[(b shr 16) and $FF] xor tiger3[(b shr 32) and $FF] xor tiger4[(b shr 48) and $FF]); + a := a + (tiger4[(b shr 8) and $FF] xor tiger3[(b shr 24) and $FF] xor tiger2[(b shr 40) and $FF] xor tiger1[(b shr 56) and $FF]); + a := a * 9; + + CurrentHash[0] := a xor aa; + CurrentHash[1] := b - bb; + CurrentHash[2] := c + cc; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); +end; + +procedure TTIGER.InitHash; +begin + Burn; + fInitialized := true; +{$WARNINGS OFF} + CurrentHash[0] := $0123456789ABCDEF; + CurrentHash[1] := $FEDCBA9876543210; + CurrentHash[2] := $F096A5B4C3B2E187; +{$WARNINGS ON} +end; + +procedure TTIGER.Burn; +begin + Len := 0; + Index := 0; + FillChar(HashBuffer, Sizeof(HashBuffer), 0); + FillChar(CurrentHash, Sizeof(CurrentHash), 0); + fInitialized := false; +end; + +procedure TTIGER.Update(const Buffer; Size: longword); +var + PBuf : ^byte; +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + + Inc(Len, Size * 8); + + PBuf := @Buffer; + while Size > 0 do + begin + if (Sizeof(HashBuffer) - Index) <= DWord(Size) then + begin + Move(PBuf^, HashBuffer[Index], Sizeof(HashBuffer) - Index); + Dec(Size, Sizeof(HashBuffer) - Index); + Inc(PBuf, Sizeof(HashBuffer) - Index); + Compress; + end + else + begin + Move(PBuf^, HashBuffer[Index], Size); + Inc(Index, Size); + Size := 0; + end; + end; +end; + +procedure TTIGER.Final(var Digest); +begin + // if not fInitialized then + // raise EDCP_hash.Create('Hash not initialized'); + HashBuffer[Index] := $01; + if Index >= 56 then + Compress; + Pint64(@HashBuffer[56])^ := Len; + Compress; + Move(CurrentHash, Digest, Sizeof(CurrentHash)); + Burn; +end; + +end. + diff --git a/Addons/KOLHttp.pas b/Addons/KOLHttp.pas new file mode 100644 index 0000000..f3e73c4 --- /dev/null +++ b/Addons/KOLHttp.pas @@ -0,0 +1,209 @@ +unit KOLHttp; + +interface + +uses + Windows, KOL, KOLSocket; + +type + + TKOLhttp =^TKOLhttpControl; + PKOLhttpControl =^TKOLhttpControl; + TKOLhttpControl = object(TObj) + private + fAdr: string; + fUrl: string; + fRef: string; + fUsr: string; + fPas: string; + fMth: string; + fPAd: string; + fPPr: integer; + fCod: integer; + Body: boolean; + fHdr: PStrList; + fCnt: PStrList; + fSoc: PAsyncSocket; + fPort: integer; + fOnClos: TOnEvent; + procedure OnDumm(Sender: TWMSocket); + procedure OnConn(Sender: TWMSocket); + procedure OnRead(Sender: TWMSocket); + procedure OnClos(Sender: TWMSocket); + procedure Prepare; + protected + procedure ParseUrl; + public + procedure Get; overload; + procedure Get(_Url: string); overload; + property Url: string read fUrl write fUrl; + property HostPort: integer read fPort write fPort; + property HostAddr: string read fAdr write fAdr; + property UserName: string read fUsr write fUsr; + property Password: string read fPas write fPas; + property Responce: integer read fCod write fCod; + property Header: PStrList read fHdr; + property Content: PStrList read fCnt; + property ProxyAddr: string read fPAd write fPAd; + property ProxyPort: integer read fPPr write fPPr; + property OnClose: TOnEvent read fOnClos write fOnClos; + end; + + function NewKOLhttpControl: PKOLhttpControl; + +implementation + +uses UStr, UWrd; + +const + bin2b64:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + +function NewKOLhttpControl: PKOLhttpControl; +begin + New(Result, create); + Result.fPort := 80; + Result.fAdr := ''; + Result.fUsr := ''; + Result.fPas := ''; + Result.fMth := 'GET'; + Result.fHdr := NewStrList; + Result.fCnt := NewStrList; +end; + +function encode_line(const buf: string):string; +var + offset: shortint; + pos1,pos2: byte; + i: byte; + out: string; +begin + setlength(out, length(buf) * 4 div 3 + 4); + fillchar(out[1], length(buf) * 4 div 3 + 2, #0); + offset:=2; + pos1:=0; + pos2:=1; + out[pos2]:=#0; +while pos1 < length(buf) do begin + if offset > 0 then begin + out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shl offset)) shr offset)); + offset:=offset-6; + inc(pos2); + out[pos2]:=#0; + end + else if offset < 0 then begin + offset:=abs(offset); + out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shr offset)) shl offset)); + offset:=8-offset; + inc(pos1); + end + else begin + out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and $3f))); + inc(pos2); + inc(pos1); + out[pos2]:=#0; + offset:=2; + end; + end; + if offset=2 then dec(pos2); + for i:=1 to pos2 do + out[i]:=bin2b64[ord(out[i])+1]; + while (pos2 and 3)<>0 do begin + inc(pos2); + out[pos2] := '='; + end; + encode_line := copy(out, 1, pos2); +end; + +procedure TKOLhttpControl.OnDumm; +begin +end; + +procedure TKOLhttpControl.OnConn; +begin + fHdr.Clear; + fCnt.Clear; + fSoc.SendString(fMth + ' ' + fRef + ' HTTP/1.1'#13#10); + fSoc.SendString('User-Agent: KOL-HTTP'#13#10); + fSoc.SendString('Host: ' + fAdr + #13#10); + if fUsr <> '' then begin + fSoc.SendString('Authorization: Basic ' + encode_line(fUsr + ':' + fPas) + #13#10); + end; + fSoc.SendString(#13#10); +end; + +procedure TKOLhttpControl.OnRead; +var s: string; +begin + while fSoc.Count > 0 do begin + s := Wordn(fSoc.ReadLine(#10), #13, 1); + if pos('<', s) = 1 then Body := True; + if Body then fCnt.Add(s) + else fHdr.Add(s); + if pos('HTTP/1.', s) = 1 then fCod := str2int(wordn(s, ' ', 2)); + end; + if Assigned(fOnClos) then fOnClos(@self); +end; + +procedure TKOLhttpControl.OnClos; +begin + if Assigned(fOnClos) then fOnClos(@self); +end; + +procedure TKOLhttpControl.ParseUrl; +var s, + r: string; +begin + s := Url; + if pos('HTTP://', UpSt(s)) = 1 then begin + s := copy(s, 8, length(s) - 7); + end; + r := wordn(s, '@', 1); + if r <> s then begin + fUsr := wordn(r, ':', 1); + fPas := wordn(r, ':', 2); + s := wordn(s, '@', 2); + end; + r := wordn(s, ':', 2); + if r <> '' then begin + fPort := str2int(r); + s := wordn(s, ':', 1); + end; + r := wordn(s, '/', 1); + fAdr := r; + if fAdr = '' then fAdr := s; + fRef := copy(s, length(fAdr) + 1, length(s) - length(fAdr)); + if fRef = '' then fRef := '/'; +end; + +procedure TKOLhttpControl.Prepare; +begin + Body := False; + fSoc := NewAsyncSocket; + ParseUrl; + fSoc.PortNumber := fPort; + fSoc.IPAddress := fAdr; + if fPAd <> '' then begin + fSoc.IPAddress := fPAd; + fSoc.PortNumber := fPPr; + fRef := 'http://' + fAdr + fRef; + end; + fSoc.OnConnect := OnConn; + fSoc.OnRead := OnRead; + fSoc.OnError := OnDumm; + fSoc.OnClose := OnClos; +end; + +procedure TKOLhttpControl.Get; +begin + Prepare; + fMth := 'GET'; + fSoc.DoConnect; +end; + +procedure TKOLhttpControl.Get(_Url: string); +begin + Url := _Url; + Get; +end; + +end. diff --git a/Addons/KOLMHToolTip.pas b/Addons/KOLMHToolTip.pas new file mode 100644 index 0000000..a98c379 --- /dev/null +++ b/Addons/KOLMHToolTip.pas @@ -0,0 +1,939 @@ +//{$DEFINE DEBUG} +{$IFDEF DEBUG} +{$DEFINE interface} +{$DEFINE implementation} +{$DEFINE initialization} +{$DEFINE finalization} +{$ENDIF} + +{$IFDEF Frame} +unit KOLMHToolTip; + + +// 8-jan-2003 + +// MHDateTimePicker Компонент (MHDateTimePicker Component) +// Автор (Author): Жаров Дмитрий (Zharov Dmitry) aka Гэндальф (Gandalf) +// Дата создания (Create date): 1-авг(aug)-2002 +// Дата коррекции (Last correction Date): 13-сен(sep)-2002 +// Версия (Version): 0.91 +// EMail: Gandalf@kol.mastak.ru +// Благодарности (Thanks): +// Alexander Pravdin +// Новое в (New in): +// V0.91 +// [+] Поддержка D6 (D6 Support) [KOLnMCK] +// +// V0.9 +// [+++] Очень много (Very much) [KOLnMCK] +// [N] KOLnMCK>=1.42 +// +// Список дел (To-Do list): +// 1. Ассемблер (Asm) +// 2. Оптимизировать (Optimize) +// 3. Изменение стилей (Styles) +// 4. Отрисовка (Draw) +// 5. Подчистить (Clear Stuff) +// 6. События (Events) +// 7. Все API (All API's) + +interface + +uses Windows, KOL, Messages; + +type +{$ENDIF Frame} +{$IFDEF interface} + + + TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay); + + TFI = record + FE: set of TFE; + Colors: array[0..1] of TColor; + Delays: array[0..3] of Integer; + end; + + PMHToolTipManager = ^TMHToolTipManager; + TKOLMHToolTipManager = PMHToolTipManager; + + PMHToolTip = ^TMHToolTip; + TKOLMHToolTip = PMHToolTip; + +{$ENDIF interface} + +{$IFDEF pre_interface} + PMHHint = ^TMHHint; + TKOLMHHint = PMHHint; +{$ENDIF pre_interface} + +{$IFDEF interface} + + TMHToolTipManager = object(TObj) + protected + destructor Destroy; virtual; + public + TTT: array of PMHToolTip; + function AddTip: Integer; + function FindNeed(FI: TFI): PMHToolTip; + function CreateNeed(FI: TFI): PMHToolTip; + end; + + TMHHint = object(TObj) + private + function GetManager:PMHToolTipManager; + // Spec + procedure ProcBegin(var TI: TToolInfo); + procedure ProcEnd(var TI: TToolInfo); + procedure ReConnect(FI: TFI); + procedure MoveTool(T1: PMHToolTip); + procedure CreateToolTip; + function GetFI: TFI; + + // Group + function GetDelay(const Index: Integer): Integer; + procedure SetDelay(const Index: Integer; const Value: Integer); + function GetColor(const Index: Integer): TColor; + procedure SetColor(const Index: Integer; const Value: TColor); + + // Local + procedure SetText(Value: KOLString); + function GetText: KOLString; + public + ToolTip: PMHToolTip; + HasTool: Boolean; + Parent: PControl; + destructor Destroy; virtual; + procedure Pop; + procedure Popup; + + property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; + property InitialDelay: Integer index 3 read GetDelay write SetDelay; + property ReshowDelay: Integer index 1 read GetDelay write SetDelay; + + property TextColor: TColor index 1 read GetColor write SetColor; + property BkColor: TColor index 0 read GetColor write SetColor; + property Text: KOLString read GetText write SetText; + end; + + TMHToolTip = object(TObj) + + private + fHandle: THandle; + Count: Integer; + + function GetDelay(const Index: Integer): Integer; + procedure SetDelay(const Index: Integer; const Value: Integer); + function GetColor(const Index: Integer): TColor; + procedure SetColor(const Index: Integer; const Value: TColor); + function GetMaxWidth: Integer; + procedure SetMaxWidth(const Value: Integer); + function GetMargin: TRect; + procedure SetMargin(const Value: TRect); + function GetActivate: Boolean; + procedure SetActivate(const Value: Boolean); +// function GetText: string; +// procedure SetText(const Value: string); +// function GetToolCount: Integer; +// function GetTool(Index: Integer): TToolInfo; + + + + protected + + public + destructor Destroy; virtual; + procedure Pop; + procedure Popup; + procedure Update; + +// function GetInfo: TToolInfo; // Hide in Info +// procedure SetInfo(Value: TToolInfo); + +// handle:Thandle; +// procedure SetC(C: PControl); +// procedure SetI(C: PControl; S: string); +// procedure Add(Value: TToolInfo); +// procedure Delete(Value: TToolInfo); +// function Connect(Value: PControl): Integer; + + +// property OnCloseUp: TOnEvent read GetOnDropDown write SetOnDropDown; + + + + property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; + property InitialDelay: Integer index 3 read GetDelay write SetDelay; + property ReshowDelay: Integer index 1 read GetDelay write SetDelay; + + property TextColor: TColor index 1 read GetColor write SetColor; + property BkColor: TColor index 0 read GetColor write SetColor; + + property MaxWidth: Integer read GetMaxWidth write SetMaxWidth; + + property Margin: TRect read GetMargin write SetMargin; + property Activate: Boolean read GetActivate write SetActivate; + property Handle: THandle read fHandle; +// property Text: string read GetText write SetText; +// property ToolCount: Integer read GetToolCount; +// property Tools[Index: Integer]: TToolInfo read GetTool; + + end; + +const + Dummy = 0; + + +function NewHint(A: PControl): PMHHint; +function NewManager: PMHToolTipManager; +function NewMHToolTip(AParent: PControl): PMHToolTip; + +var + Manager: PMHToolTipManager; + +{$ENDIF interface} + +{$IFDEF Frame} + +implementation + +{$ENDIF Frame} + +{$IFDEF implementation} + +const + Dummy1 = 1; + + TTDT_AUTOMATIC = 0; + TTDT_RESHOW = 1; + TTDT_AUTOPOP = 2; + TTDT_INITIAL = 3; + +//function WndProcMHDateTimePicker(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +{begin + Result := False;} +//end; + + + +function NewMHToolTip(AParent: PControl): PMHToolTip; +//var +// Data: PDateTimePickerData; +// T: TWndClassEx; +// a: integer; +const + CS_DROPSHADOW = $00020000; +begin + DoInitCommonControls(ICC_BAR_CLASSES); + New(Result, Create); + + Result.fHandle := CreateWindowEx(0, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 0, HInstance, nil); + +// SetClassLong(Result.handle,GCL_STYLE,CS_DROPSHADOW); + +// Result := PMHToolTip(_NewControl(AParent, TOOLTIPS_CLASS, 0, False, 0)); //PMHToolTip(_NewCommonControl(AParent,TOOLTIPS_CLASS, 0{TTS_ALWAYSTIP}{WS_CHILD or WS_VISIBLE},False,0)); +// Result.Style:=0; +// Result.ExStyle:=0; +// GetMem(Data,Sizeof(Data^)); +// FillChar(Data^,Sizeof(Data^),0); +// a:=SetClassLong(Result.Handle,GCL_STYLE,CS_DROPSHADOW); +// ShowMessage(Int2Str(a)); +// Result.CustomData:=Data; + +{ T.cbSize:=SizeOf(T); + GetClassInfoEx(hInstance,TOOLTIPS_CLASS,T); + T.style:=T.style or CS_DROPSHADOW; + T.hInstance:=hInstance; + T.lpszClassName:='ZharovHint'; + a:=RegisterClassEx(T); + ShowMessage(Int2Str(a)); } +// Result.handle := CreateWindowEx(0, {'ZharovHint'} TOOLTIPS_CLASS, '', 0 {orCS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS}, CW_USEDEFAULT, CW_USEDEFAULT, +// CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 0, HInstance, nil); +// Data.ttt:=CreateWindowEx (CS_IMEWS_EX_TOOLWINDOW or WS_EX_CONTROLPARENT{ or CS_SAVEBITS or WS_POPUP or WS_BORDER}{65536},{'ZharovHint'}TOOLTIPS_CLASS,'',{WS_CHILD or}{ WS_VISIBLE}{100663296}{WS_EX_TOOLWINDOW}CS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS,CW_USEDEFAULT,CW_USEDEFAULT, +// CW_USEDEFAULT,CW_USEDEFAULT,AParent.Handle,0,HInstance,NIL); +// SetClassLong(Data.ttt,GCL_STYLE,CS_DROPSHADOW); +// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_INITIAL,5); +// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_RESHOW,20); +// SendMessage (Result.handle,TTM_SETDELAYTIME,TTDT_AUTOPOP,2000); +// Result.CreateWindow; +// Result.Parent := AParent; +// Result.Perform(TTM_SETTIPTEXTCOLOR,clRed,0); +// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clBlue,0); +// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clRed,0); +// Result.Color:=clRed; +// Result.Font.Color:=clRed; +// Data.FCalColors:=NewMonthCalColors(Result); +// Data.FOnDropDown:=nil; +// Result.AttachProc(WndProcMHDateTimePicker); +// Result.AttachProc(WndProcMHDateTimePicker); +end; + +{procedure TMHToolTip.SetC(C: PControl); +var + TI: TToolInfo; + R: Trect; +// Data:PDateTimePickerData; +begin + R := C.ClientRect; + // Control:= C.Handle; + with TI do + begin + cbSize := SizeOf(TI); + uFlags := TTF_SUBCLASS; // or TTF_IDISHWND; + hWnd := C.GetWindowHandle; //Control; + uId := 0; + rect.Left := R.Left; + rect.Top := R.Top; + rect.Right := R.Right; + rect.Bottom := R.Bottom; + hInst := 0; + lpszText := Pchar('I am ' + C.Caption); + end; + PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI)); +// Perform(TTM_ADDTOOL, 0, DWord(@TI)); +end; } + +function TMHToolTip.GetDelay(const Index: Integer): Integer; +begin + Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0); +end; + + +procedure TMHToolTip.SetDelay(const Index, Value: Integer); +begin + SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0)); +end; + + +function TMHToolTip.GetColor(const Index: Integer): TColor; +begin + Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0); +end; + +procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor); +begin + SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0); +end; + +function TMHToolTip.GetMaxWidth: Integer; +begin + Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0); +end; + +procedure TMHToolTip.SetMaxWidth(const Value: Integer); +begin + SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value); +end; + +{procedure TMHToolTip.SetI(C: PControl; S: string); +var + TI: TToolInfo; + R: Trect; +// Data:PDateTimePickerData; +begin + R := C.ClientRect; + // Control:= C.Handle; + with TI do + begin + cbSize := SizeOf(TI); + uFlags := TTF_SUBCLASS; + hWnd := C.GetWindowHandle; //Control; + uId := 0; + rect.Left := R.Left; + rect.Top := R.Top; + rect.Right := R.Right; + rect.Bottom := R.Bottom; + hInst := 0; + lpszText := PChar(S); + end; +// PostMessage (handle,TTM_ADDTOOL,0,DWORD (@TI)); +// Perform(TTM_SETTOOLINFO, 0, DWord(@TI)); +end; } + +function TMHToolTip.GetMargin: TRect; +begin + SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result)); +end; + +procedure TMHToolTip.SetMargin(const Value: TRect); +begin + SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value)); +end; + +function TMHToolTip.GetActivate: Boolean; +begin + // ?????? + Result := False; +end; + +procedure TMHToolTip.SetActivate(const Value: Boolean); +begin + SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0); +end; + +procedure TMHToolTip.Pop; +begin + SendMessage(fHandle, TTM_POP, 0, 0); +end; + +procedure TMHToolTip.Popup; +begin + SendMessage(fHandle, TTM_POPUP, 0, 0); +end; + +{function TMHToolTip.GetText: string; +begin + +end; + +procedure TMHToolTip.SetText(const Value: string); +var + TI: TToolInfo; +begin + TI := GetInfo; + TI.lpszText := PChar(Value); + SetInfo(TI); +end; } + +{function TMHToolTip.GetInfo: TToolInfo; +begin + with Result do + begin + // ???? + FillChar(Result, SizeOf(Result), 0); + cbSize := SizeOf(Result); +// hWnd := Parent.GetWindowHandle; + uId := 0; + end; +// Perform(TTM_GETTOOLINFO, 0, DWord(@Result)); +end; + +procedure TMHToolTip.SetInfo(Value: TToolInfo); +begin +// Perform(TTM_SETTOOLINFO, 0, DWord(@Value)); +end;} + +{function TMHToolTip.GetToolCount: Integer; +begin +// Result := Perform(TTM_GETTOOLCOUNT, 0, 0); +end; + +function TMHToolTip.GetTool(Index: Integer): TToolInfo; +begin + FillChar(Result, SizeOf(Result), 0); // ???? + Result.cbSize := SizeOf(Result); +// Perform(TTM_ENUMTOOLS, Index, DWord(@Result)); +end; } + +{procedure TMHToolTip.Add(Value: TToolInfo); +begin +// Perform(TTM_ADDTOOL, 0, DWord(@Value)); +end;} + +{procedure TMHToolTip.Delete(Value: TToolInfo); +begin +// Perform(TTM_DELTOOL, 0, DWord(@Value)); +end;} + +procedure TMHToolTip.Update; +begin + inherited; // ??? + SendMessage(fHandle, TTM_UPDATE, 0, 0); +end; + +function NewHint(A: PControl): PMHHint; +begin + New(Result, Create); + + with Result^ do + begin + Parent := A; + ToolTip := nil; // ??? + HasTool := False; // ??? + end; +end; + +function NewManager: PMHToolTipManager; +begin + New(Result, Create); +end; + +{ TMHHint } + +function TMHHint.GetDelay(const Index: Integer): Integer; +begin +// CreateToolTip; + Result := 0; + if Assigned(ToolTip) then + Result := ToolTip.GetDelay(Index); +end; + +function TMHHint.GetFI: TFI; +begin + /// !!! DANGER-WITH !!! + with Result, ToolTip^ do + begin + FE := FE + [eTextColor]; + Colors[1] := TextColor; + + FE := FE + [eBkColor]; + Colors[0] := BkColor; + + FE := FE + [eAPDelay]; + Delays[TTDT_AUTOPOP] := AutoPopDelay; + + FE := FE + [eRDelay]; + Delays[TTDT_RESHOW] := ReshowDelay; + + FE := FE + [eIDelay]; + Delays[TTDT_INITIAL] := InitialDelay; + end; +end; + +procedure TMHHint.ReConnect(FI: TFI); +var + TMP: PMHToolTip; +begin + with GetManager^ do + begin + TMP := FindNeed(FI); + if not Assigned(TMP) then + TMP := CreateNeed(FI); + if Assigned(ToolTip) and HasTool then + MoveTool(TMP); + ToolTip := TMP; + end; +end; + +procedure TMHHint.MoveTool(T1: PMHToolTip); +var + TI: TToolInfo; + TextL: array[0..255] of KOLChar; +begin + if T1 = ToolTip then + Exit; + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + lpszText := @TextL[0]; + end; + + SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); + SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); + ToolTip.Count := ToolTip.Count - 1; + SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI)); + T1.Count := T1.Count - 1; + + HasTool := True; + +end; + +procedure TMHHint.SetColor(const Index: Integer; const Value: TColor); +var + FI: TFI; +begin + if Assigned(ToolTip) then + begin + if ToolTip.Count + Byte(not HasTool) = 1 then + begin + ToolTip.SetColor(Index, Value); + Exit; + end; + FI := GetFI; + end; + + case Index of + 0: FI.FE := FI.FE + [eBkColor]; + 1: FI.FE := FI.FE + [eTextColor]; + end; + FI.Colors[Index] := Value; + + ReConnect(FI); +end; + +function TMHHint.GetColor(const Index: Integer): TColor; +begin + Result := 0; + if Assigned(ToolTip) then + Result := ToolTip.GetColor(Index); +end; + +procedure TMHHint.SetDelay(const Index, Value: Integer); +var + FI: TFI; +begin + if Assigned(ToolTip) then + begin + if ToolTip.Count + Byte(not HasTool) = 1 then + begin + ToolTip.SetDelay(Index, Value); + Exit; + end; + FI := GetFI; + end; + + case Index of + TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec + TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec + TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec + end; //case + + FI.Delays[Index] := Value; //Spec + + ReConnect(FI); +end; + +procedure TMHHint.SetText(Value: KOLString); +var + TI: TToolInfo; +begin + ProcBegin(TI); + + with TI do + begin + uFlags := TTF_SUBCLASS; // Spec + //rect := Parent.ClientRect; // Spec + rect := MakeRect( 0, 0, 2048, 1600 ); + // это ничему не мешает, и обеспечивает независимость от размера контрола, + // который может изменяться в процессе работы + lpszText := PKOLChar(Value); // Spec + end; + + procEnd(TI); + + if HasTool then + begin + TI.lpszText := PKOLChar(Value); + SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); + end; + +end; + +(* +procedure TMHHint.SetText(Value: string); +var + TI: TToolInfo; + R: Trect; + TextLine: array[0..255] of Char; +begin + if not Assigned(ToolTip) then + begin + if Length(Manager.TTT) = 0 then + Manager.AddTip; + ToolTip := Manager.TTT[0]; + end; + + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + hInst := 0; + end; + + if not HasTool {TTool = -1} then + begin + R := Parent.ClientRect; + // Control:= C.Handle; + with TI do + begin +// cbSize := SizeOf(TI); + uFlags := TTF_SUBCLASS; +// hWnd := Parent.GetWindowHandle; //Control; +// uId := Parent.GetWindowHandle; + rect.Left := R.Left; + rect.Top := R.Top; + rect.Right := R.Right; + rect.Bottom := R.Bottom; +// hInst := 0; + lpszText := PChar(Value); + end; + SendMessage({Manager.TTT[TTip]} ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); + HasTool := True; +// TTool := 0; + ToolTip {Manager.TTT[TTip]}.Count := ToolTip {Manager.TTT[TTip]}.Count + 1; + + end + else + begin + + with TI do + begin + // ???? +// FillChar(TI, SizeOf(TI), 0); +// cbSize := SizeOf(TI); +// hWnd := Parent.GetWindowHandle; +// uId := Parent.GetWindowHandle; + lpszText := @TextLine; //PChar(S); + end; + SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); + TI.lpszText := PChar(Value); +// Perform(TTM_GETTOOLINFO, 0, DWord(@Result)); + SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); + end; +// Manager.TTT[TTip].Tool[TTool].SSSetText(Value); +end; +*) + +{ TMHToolTipManager } + +{function TMHToolTipManager.AddColor(C: TColor): Integer; +begin + SetLength(TTT, Length(TTT) + 1); + TTT[Length(TTT) - 1] := NewMHToolTip(Applet); + TTT[Length(TTT) - 1].SetColor(1, C); + Result := Length(TTT) - 1; +end; } + +function TMHToolTipManager.AddTip: Integer; +begin + SetLength(TTT, Length(TTT) + 1); + TTT[Length(TTT) - 1] := NewMHToolTip(Applet); + Result := Length(TTT) - 1; +end; + +{function TMHToolTip.Connect(Value: PControl): Integer; +var + TI: TToolInfo; + R: Trect; +// Data:PDateTimePickerData; +begin + R := Value.ClientRect; + // Control:= C.Handle; + with TI do + begin + cbSize := SizeOf(TI); + uFlags := TTF_SUBCLASS; + hWnd := Value.GetWindowHandle; //Control; + uId := Value.GetWindowHandle; + rect.Left := R.Left; + rect.Top := R.Top; + rect.Right := R.Right; + rect.Bottom := R.Bottom; + hInst := 0; + lpszText := PChar('Super'); + end; + PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI)); +// Perform(TTM_ADDTOOL, 0, DWord(@TI)); +end;} + +{function TMHToolTipManager.FindTip(N: Integer): Integer; +begin + Result := -1; +end;} + +function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip; +var + i: Integer; +begin + Result := nil; + for i := 0 to length(TTT) - 1 do + begin + if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or + ((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or + ((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or + ((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or + ((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then + Continue; + Result := TTT[i]; + Break; + end; +end; + +function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip; + +begin + Setlength(TTT, length(TTT) + 1); + TTT[length(TTT) - 1] := NewMHToolTip(Applet); + with TTT[length(TTT) - 1]^ do + begin + if (eTextColor in FI.FE) then + TextColor := FI.Colors[1]; + if (eBkColor in FI.FE) then + BkColor := FI.Colors[0]; + if (eAPDelay in FI.FE) then + AutoPopDelay := FI.Delays[TTDT_AUTOPOP]; + if (eIDelay in FI.FE) then + InitialDelay := FI.Delays[TTDT_INITIAL]; + if (eRDelay in FI.FE) then + ReshowDelay := FI.Delays[TTDT_RESHOW]; + end; + Result := TTT[length(TTT) - 1]; +end; + +procedure TMHHint.ProcBegin(var TI: TToolInfo); +begin + CreateToolTip; + + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + hInst := 0; + end; +end; + +procedure TMHHint.ProcEnd(var TI: TToolInfo); +var + TextLine: array[0..255] of KOLChar; +begin + if not HasTool then + begin + SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); + HasTool := True; + ToolTip.Count := ToolTip.Count + 1; + end + else + begin + with TI do + begin + lpszText := @TextLine[0]; + end; + SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); + end; +end; + +destructor TMHToolTipManager.Destroy; +var + i: Integer; +begin + for i := 0 to Length(TTT) - 1 do + TTT[i].Free; + SetLength(TTT, 0); + inherited; +end; + +procedure TMHHint.Pop; +begin + if Assigned(ToolTip) and (HasTool) then + begin // ^^^^^^^^^^^^ ??? +// CreateToolTip; + ToolTip.Pop; + end; +end; + +procedure TMHHint.Popup; +begin + if Assigned(ToolTip) and (HasTool) then + begin // ^^^^^^^^^^^^ ??? +// CreateToolTip; + ToolTip.Popup; + end; +end; + +destructor TMHHint.Destroy; +var + TI: TToolInfo; +begin + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + end; + + SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); + ToolTip.Count := ToolTip.Count - 1; + Manager.Free; + inherited; +end; + +destructor TMHToolTip.Destroy; +begin + inherited; +end; + +procedure TMHHint.CreateToolTip; +begin + if not Assigned(ToolTip) then + begin + if Length(GetManager.TTT) = 0 then + GetManager.AddTip; + ToolTip := GetManager.TTT[0]; + end; +end; + +function TMHHint.GetText: KOLString; +var + TI: TToolInfo; + TextL: array[0..255] of KOLChar; +begin + if Assigned(ToolTip) and (HasTool) then + begin + // !!! + with TI do + begin + // ???? +// FillChar(TI, SizeOf(TI), 0); + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + lpszText := @TextL[0]; + end; + SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); + Result := TextL; //TI.lpszText;// := PChar(Value); + end; +end; + +function TMHHint.GetManager: PMHToolTipManager; +begin + if Manager=nil then + Manager:=NewManager; + Result:=Manager; +end; + +{$ENDIF implementation} + +{$IFDEF Frame} + +initialization +{$ENDIF Frame} +{$IFDEF initialization} + + Manager := NewManager; +{$ENDIF initialization} + +{$IFDEF Frame} +finalization +{$ENDIF Frame} +{$IFDEF finalization} +// Manager.Free; +{$ENDIF finalization} + + +{$IFDEF Frame} +end. +{$ENDIF Frame} + +{$IFDEF function} +function GetHint: PMHHint; +{$ENDIF function} + +{$IFDEF public} + property Hint: PMHHint read GetHint; + {$ENDIF public} + + {$IFDEF code} + function TControl.GetHint: PMHHint; + begin + if fHint = nil then + fHint := NewHint(@Self); + Result := fHint; + end; + {$ENDIF code} + + {$IFDEF MHdestroy} + fHint.Free; + {$ENDIF MHdestroy} + + {$IFDEF var} + fHint: PMHHint; + {$ENDIF var} + + + + + diff --git a/Addons/KOLMath.pas b/Addons/KOLMath.pas new file mode 100644 index 0000000..d70154a --- /dev/null +++ b/Addons/KOLMath.pas @@ -0,0 +1,1780 @@ +{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + KKKKK KKKKK OOOOOOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKKKKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL + KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL + + Key Objects Library (C) 2000 by Kladov Vladimir. + + mailto: bonanzas@xcl.cjb.net + Home: http://bonanzas.rinet.ru + http://xcl.cjb.net + + =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} +{ + This code is grabbed from standard math.pas unit, + provided by Borland Delphi. This unit is for working with + engineering (mathematical) functions. The main difference + is that err unit specially designed to handle exceptions + for KOL is used instead of SysUtils. This allows to make + size of the executable smaller for about 5K. though this + value is insignificant for project made with VCL, it can + be more than 15% of executable file size made with KOL. +} + +{*******************************************************} +{ } +{ Borland Delphi Runtime Library } +{ Math Unit } +{ } +{ Copyright (C) 1996,99 Inprise Corporation } +{ } +{*******************************************************} + +unit kolmath; + +{ This unit contains high-performance arithmetic, trigonometric, logorithmic, + statistical and financial calculation routines which supplement the math + routines that are part of the Delphi language or System unit. } + +{$N+,S-} + +{$I KOLDEF.INC} + +interface + +uses err, kol; + +const { Ranges of the IEEE floating point types, including denormals } + MinSingle = 1.5e-45; + MaxSingle = 3.4e+38; + MinDouble = 5.0e-324; + MaxDouble = 1.7e+308; + MinExtended = 3.4e-4932; + MaxExtended = 1.1e+4932; + MinComp = -9.223372036854775807e+18; + MaxComp = 9.223372036854775807e+18; + +{----------------------------------------------------------------------- +References: + +1) P.J. Plauger, "The Standard C Library", Prentice-Hall, 1992, Ch. 7. +2) W.J. Cody, Jr., and W. Waite, "Software Manual For the Elementary + Functions", Prentice-Hall, 1980. +3) Namir Shammas, "C/C++ Mathematical Algorithms for Scientists and Engineers", + McGraw-Hill, 1995, Ch 8. +4) H.T. Lau, "A Numerical Library in C for Scientists and Engineers", + CRC Press, 1994, Ch. 6. +5) "Pentium(tm) Processor User's Manual, Volume 3: Architecture + and Programming Manual", Intel, 1994 ++6)Уоррен Младший, "Арифметические трюки для программистов", исправленное изд., + 2004 + +All angle parameters and results of trig functions are in radians. + +Most of the following trig and log routines map directly to Intel 80387 FPU +floating point machine instructions. Input domains, output ranges, and +error handling are determined largely by the FPU hardware. +Routines coded in assembler favor the Pentium FPU pipeline architecture. +-----------------------------------------------------------------------} + +function EAbs( D: Double ): Double; +function EMax( const Values: array of Double ): Double; +function EMin( const Values: array of Double ): Double; +function ESign( X: Extended ): Integer; +function iMax( const Values: array of Integer ): Integer; +function iMin( const Values: array of Integer ): Integer; +function iSign( i: Integer ): Integer; + +{ Trigonometric functions } +function ArcCos(X: Extended): Extended; { IN: |X| <= 1 OUT: [0..PI] radians } +function ArcSin(X: Extended): Extended; { IN: |X| <= 1 OUT: [-PI/2..PI/2] radians } + +{ ArcTan2 calculates ArcTan(Y/X), and returns an angle in the correct quadrant. + IN: |Y| < 2^64, |X| < 2^64, X <> 0 OUT: [-PI..PI] radians } +function ArcTan2(Y, X: Extended): Extended; + +{ SinCos is 2x faster than calling Sin and Cos separately for the same angle } +procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register; +function Tan(X: Extended): Extended; +function Cotan(X: Extended): Extended; { 1 / tan(X), X <> 0 } +function Hypot(X, Y: Extended): Extended; { Sqrt(X**2 + Y**2) } + +{ Angle unit conversion routines } +function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180} +function RadToDeg(Radians: Extended): Extended; { Degrees := Radians * 180 / PI } +function GradToRad(Grads: Extended): Extended; { Radians := Grads * PI / 200 } +function RadToGrad(Radians: Extended): Extended; { Grads := Radians * 200 / PI } +function CycleToRad(Cycles: Extended): Extended; { Radians := Cycles * 2PI } +function RadToCycle(Radians: Extended): Extended;{ Cycles := Radians / 2PI } + +{ Hyperbolic functions and inverses } +function Cosh(X: Extended): Extended; +function Sinh(X: Extended): Extended; +function Tanh(X: Extended): Extended; +function ArcCosh(X: Extended): Extended; { IN: X >= 1 } +function ArcSinh(X: Extended): Extended; +function ArcTanh(X: Extended): Extended; { IN: |X| <= 1 } + +{ Logorithmic functions } +function LnXP1(X: Extended): Extended; { Ln(X + 1), accurate for X near zero } +function Log10(X: Extended): Extended; { Log base 10 of X} +function Log2(X: Extended): Extended; { Log base 2 of X } +function LogN(Base, X: Extended): Extended; { Log base N of X } + +{ Exponential functions } + +{ IntPower: Raise base to an integral power. Fast. } +//function IntPower(Base: Extended; Exponent: Integer): Extended register; +// -- already defined in kol.pas + +{ Power: Raise base to any power. + For fractional exponents, or |exponents| > MaxInt, base must be > 0. } +function Power(Base, Exponent: Extended): Extended; +{$IFNDEF _D6orHigher} +function Trunc( X: Extended ): Int64; +{$ENDIF} + +{ Miscellaneous Routines } + +{ Frexp: Separates the mantissa and exponent of X. } +procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register; + +{ Ldexp: returns X*2**P } +function Ldexp(X: Extended; P: Integer): Extended register; + +{ Ceil: Smallest integer >= X, |X| < MaxInt } +function Ceil(X: Extended):Integer; + +{ Floor: Largest integer <= X, |X| < MaxInt } +function Floor(X: Extended): Integer; + +{ Poly: Evaluates a uniform polynomial of one variable at value X. + The coefficients are ordered in increasing powers of X: + Coefficients[0] + Coefficients[1]*X + ... + Coefficients[N]*(X**N) } +function Poly(X: Extended; const Coefficients: array of Double): Extended; + +{----------------------------------------------------------------------- +Statistical functions. + +Common commercial spreadsheet macro names for these statistical and +financial functions are given in the comments preceding each function. +-----------------------------------------------------------------------} + +{ Mean: Arithmetic average of values. (AVG): SUM / N } +function Mean(const Data: array of Double): Extended; + +{ Sum: Sum of values. (SUM) } +function Sum(const Data: array of Double): Extended register; +function SumInt(const Data: array of Integer): Integer register; +function SumOfSquares(const Data: array of Double): Extended; +procedure SumsAndSquares(const Data: array of Double; + var Sum, SumOfSquares: Extended) register; + +{ MinValue: Returns the smallest signed value in the data array (MIN) } +function MinValue(const Data: array of Double): Double; +function MinIntValue(const Data: array of Integer): Integer; + +function Min(A,B: Integer): Integer; +{$IFDEF _D4orHigher} +overload; +function Min(A,B: I64): I64; overload; +function Min(A,B: Int64): Int64; overload; +function Min(A,B: Single): Single; overload; +function Min(A,B: Double): Double; overload; +function Min(A,B: Extended): Extended; overload; +{$ENDIF} + +{ MaxValue: Returns the largest signed value in the data array (MAX) } +function MaxValue(const Data: array of Double): Double; +function MaxIntValue(const Data: array of Integer): Integer; + +function Max(A,B: Integer): Integer; +{$IFDEF _D4orHigher} +overload; +function Max(A,B: I64): I64; overload; +function Max(A,B: Single): Single; overload; +function Max(A,B: Double): Double; overload; +function Max(A,B: Extended): Extended; overload; +{$ENDIF} + +{ Standard Deviation (STD): Sqrt(Variance). aka Sample Standard Deviation } +function StdDev(const Data: array of Double): Extended; + +{ MeanAndStdDev calculates Mean and StdDev in one call. } +procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); + +{ Population Standard Deviation (STDP): Sqrt(PopnVariance). + Used in some business and financial calculations. } +function PopnStdDev(const Data: array of Double): Extended; + +{ Variance (VARS): TotalVariance / (N-1). aka Sample Variance } +function Variance(const Data: array of Double): Extended; + +{ Population Variance (VAR or VARP): TotalVariance/ N } +function PopnVariance(const Data: array of Double): Extended; + +{ Total Variance: SUM(i=1,N)[(X(i) - Mean)**2] } +function TotalVariance(const Data: array of Double): Extended; + +{ Norm: The Euclidean L2-norm. Sqrt(SumOfSquares) } +function Norm(const Data: array of Double): Extended; + +{ MomentSkewKurtosis: Calculates the core factors of statistical analysis: + the first four moments plus the coefficients of skewness and kurtosis. + M1 is the Mean. M2 is the Variance. + Skew reflects symmetry of distribution: M3 / (M2**(3/2)) + Kurtosis reflects flatness of distribution: M4 / Sqr(M2) } +procedure MomentSkewKurtosis(const Data: array of Double; + var M1, M2, M3, M4, Skew, Kurtosis: Extended); + +{ RandG produces random numbers with Gaussian distribution about the mean. + Useful for simulating data with sampling errors. } +function RandG(Mean, StdDev: Extended): Extended; + +{----------------------------------------------------------------------- +Financial functions. Standard set from Quattro Pro. + +Parameter conventions: + +From the point of view of A, amounts received by A are positive and +amounts disbursed by A are negative (e.g. a borrower's loan repayments +are regarded by the borrower as negative). + +Interest rates are per payment period. 11% annual percentage rate on a +loan with 12 payments per year would be (11 / 100) / 12 = 0.00916667 + +-----------------------------------------------------------------------} + +type + TPaymentTime = (ptEndOfPeriod, ptStartOfPeriod); + +{ Double Declining Balance (DDB) } +function DoubleDecliningBalance(Cost, Salvage: Extended; + Life, Period: Integer): Extended; + +{ Future Value (FVAL) } +function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: + Extended; PaymentTime: TPaymentTime): Extended; + +{ Interest Payment (IPAYMT) } +function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue, + FutureValue: Extended; PaymentTime: TPaymentTime): Extended; + +{ Interest Rate (IRATE) } +function InterestRate(NPeriods: Integer; + Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; + +{ Internal Rate of Return. (IRR) Needs array of cash flows. } +function InternalRateOfReturn(Guess: Extended; + const CashFlows: array of Double): Extended; + +{ Number of Periods (NPER) } +function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended; + PaymentTime: TPaymentTime): Extended; + +{ Net Present Value. (NPV) Needs array of cash flows. } +function NetPresentValue(Rate: Extended; const CashFlows: array of Double; + PaymentTime: TPaymentTime): Extended; + +{ Payment (PAYMT) } +function Payment(Rate: Extended; NPeriods: Integer; + PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; + +{ Period Payment (PPAYMT) } +function PeriodPayment(Rate: Extended; Period, NPeriods: Integer; + PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; + +{ Present Value (PVAL) } +function PresentValue(Rate: Extended; NPeriods: Integer; + Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; + +{ Straight Line depreciation (SLN) } +function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended; + +{ Sum-of-Years-Digits depreciation (SYD) } +function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended; + +{type + EInvalidArgument = class(EMathError) end;} + +{------------------------------------------------------------------------------} +{ Integer and logical functions } +function IsPowerOf2( i: Integer ): Boolean; +{* TRUE, если число является степенью числа 2 } + +function Low1( i: Integer ): Integer; +{* Выделяет младший бит 1 из числа i. } + +function Low0( i: Integer ): Integer; +{* Выделяет младший справа бит 0 из числа i, например, 1100011 -> 100 } + +function count_1_bits_in_byte( x: Byte ): Byte; +{* Подсчитывает число единичных битов в байте } + +function count_1_bits_in_dword( x: Integer ): Integer; +{* Подсчитывает число единичных битов в 32-битном } + + +implementation + +{$IFNDEF _D2orD3} +uses SysConst; +{$ENDIF} + +function EAbs( D: Double ): Double; +begin + Result := D; + if Result < 0.0 then + Result := -Result; +end; + +function EMax( const Values: array of Double ): Double; +var I: Integer; +begin + Result := Values[ 0 ]; + for I := 1 to High( Values ) do + if Result < Values[ I ] then Result := Values[ I ]; +end; + +function EMin( const Values: array of Double ): Double; +var I: Integer; +begin + Result := Values[ 0 ]; + for I := 1 to High( Values ) do + if Result > Values[ I ] then Result := Values[ I ]; +end; + +function ESign( X: Extended ): Integer; +begin + if X < 0 then Result := -1 + else if X > 0 then Result := 1 + else Result := 1; +end; + +function iMax( const Values: array of Integer ): Integer; +var I: Integer; +begin + Result := Values[ 0 ]; + for I := 1 to High( Values ) do + if Result < Values[ I ] then Result := Values[ I ]; +end; + +function iMin( const Values: array of Integer ): Integer; +var I: Integer; +begin + Result := Values[ 0 ]; + for I := 1 to High( Values ) do + if Result > Values[ I ] then Result := Values[ I ]; +end; + +{$IFDEF PAS_VERSION} +function iSign( i: Integer ): Integer; +begin + if i < 0 then Result := -1 + else if i > 0 then Result := 1 + else Result := 0; +end; +{$ELSE} +function iSign( i: Integer ): Integer; +asm + XOR EDX, EDX + TEST EAX, EAX + JZ @@exit + MOV DL, 1 + JG @@exit + OR EDX, -1 +@@exit: + XCHG EAX, EDX +end; +{$ENDIF} + +function Annuity2(R: Extended; N: Integer; PaymentTime: TPaymentTime; + var CompoundRN: Extended): Extended; Forward; +function Compound(R: Extended; N: Integer): Extended; Forward; +function RelSmall(X, Y: Extended): Boolean; Forward; + +type + TPoly = record + Neg, Pos, DNeg, DPos: Extended + end; + +const + MaxIterations = 15; + +procedure ArgError(const Msg: string); +begin + raise Exception.Create(e_Math_InvalidArgument, Msg); +end; + +function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180 } +begin + Result := Degrees * (PI / 180); +end; + +function RadToDeg(Radians: Extended): Extended; { Degrees := Radians * 180 / PI } +begin + Result := Radians * (180 / PI); +end; + +function GradToRad(Grads: Extended): Extended; { Radians := Grads * PI / 200 } +begin + Result := Grads * (PI / 200); +end; + +function RadToGrad(Radians: Extended): Extended; { Grads := Radians * 200 / PI} +begin + Result := Radians * (200 / PI); +end; + +function CycleToRad(Cycles: Extended): Extended; { Radians := Cycles * 2PI } +begin + Result := Cycles * (2 * PI); +end; + +function RadToCycle(Radians: Extended): Extended;{ Cycles := Radians / 2PI } +begin + Result := Radians / (2 * PI); +end; + +function LnXP1(X: Extended): Extended; +{ Return ln(1 + X). Accurate for X near 0. } +asm + FLDLN2 + MOV AX,WORD PTR X+8 { exponent } + FLD X + CMP AX,$3FFD { .4225 } + JB @@1 + FLD1 + FADD + FYL2X + JMP @@2 +@@1: + FYL2XP1 +@@2: + FWAIT +end; + +{ Invariant: Y >= 0 & Result*X**Y = X**I. Init Y = I and Result = 1. } +{function IntPower(X: Extended; I: Integer): Extended; +var + Y: Integer; +begin + Y := Abs(I); + Result := 1.0; + while Y > 0 do begin + while not Odd(Y) do + begin + Y := Y shr 1; + X := X * X + end; + Dec(Y); + Result := Result * X + end; + if I < 0 then Result := 1.0 / Result +end; +} +(* -- already defined in kol.pas +function IntPower(Base: Extended; Exponent: Integer): Extended; +asm + mov ecx, eax + cdq + fld1 { Result := 1 } + xor eax, edx + sub eax, edx { eax := Abs(Exponent) } + jz @@3 + fld Base + jmp @@2 +@@1: fmul ST, ST { X := Base * Base } +@@2: shr eax,1 + jnc @@1 + fmul ST(1),ST { Result := Result * X } + jnz @@1 + fstp st { pop X from FPU stack } + cmp ecx, 0 + jge @@3 + fld1 + fdivrp { Result := 1 / Result } +@@3: + fwait +end; +*) + +function Compound(R: Extended; N: Integer): Extended; +{ Return (1 + R)**N. } +begin + Result := IntPower(1.0 + R, N) +end; + +function Annuity2(R: Extended; N: Integer; PaymentTime: TPaymentTime; + var CompoundRN: Extended): Extended; +{ Set CompoundRN to Compound(R, N), + return (1+Rate*PaymentTime)*(Compound(R,N)-1)/R; +} +begin + if R = 0.0 then + begin + CompoundRN := 1.0; + Result := N; + end + else + begin + { 6.1E-5 approx= 2**-14 } + if EAbs(R) < 6.1E-5 then + begin + CompoundRN := Exp(N * LnXP1(R)); + Result := N*(1+(N-1)*R/2); + end + else + begin + CompoundRN := Compound(R, N); + Result := (CompoundRN-1) / R + end; + if PaymentTime = ptStartOfPeriod then + Result := Result * (1 + R); + end; +end; {Annuity2} + + +procedure PolyX(const A: array of Double; X: Extended; var Poly: TPoly); +{ Compute A[0] + A[1]*X + ... + A[N]*X**N and X * its derivative. + Accumulate positive and negative terms separately. } +var + I: Integer; + Neg, Pos, DNeg, DPos: Extended; +begin + Neg := 0.0; + Pos := 0.0; + DNeg := 0.0; + DPos := 0.0; + for I := High(A) downto Low(A) do + begin + DNeg := X * DNeg + Neg; + Neg := Neg * X; + DPos := X * DPos + Pos; + Pos := Pos * X; + if A[I] >= 0.0 then + Pos := Pos + A[I] + else + Neg := Neg + A[I] + end; + Poly.Neg := Neg; + Poly.Pos := Pos; + Poly.DNeg := DNeg * X; + Poly.DPos := DPos * X; +end; {PolyX} + + +function RelSmall(X, Y: Extended): Boolean; +{ Returns True if X is small relative to Y } +const + C1: Double = 1E-15; + C2: Double = 1E-12; +begin + Result := EAbs(X) < (C1 + C2 * EAbs(Y)) +end; + +{ Math functions. } + +function ArcCos(X: Extended): Extended; +begin + if X > 0.999999999999999 then + Result := 0 {иначе -NAN !} + else + if X < -0.999999999999999 then + Result := PI + else + Result := ArcTan2(Sqrt(1 - X*X), X); +end; + +function ArcSin(X: Extended): Extended; +begin + Result := ArcTan2(X, Sqrt(1 - X*X)) +end; + +function ArcTan2(Y, X: Extended): Extended; +asm + FLD Y + FLD X + FPATAN + FWAIT +end; + +function Tan(X: Extended): Extended; +{ Tan := Sin(X) / Cos(X) } +asm + FLD X + FPTAN + FSTP ST(0) { FPTAN pushes 1.0 after result } + FWAIT +end; + +function CoTan(X: Extended): Extended; +{ CoTan := Cos(X) / Sin(X) = 1 / Tan(X) } +asm + FLD X + FPTAN + FDIVRP + FWAIT +end; + +function Hypot(X, Y: Extended): Extended; +{ formula: Sqrt(X*X + Y*Y) + implemented as: |Y|*Sqrt(1+Sqr(X/Y)), |X| < |Y| for greater precision +var + Temp: Extended; +begin + X := Abs(X); + Y := Abs(Y); + if X > Y then + begin + Temp := X; + X := Y; + Y := Temp; + end; + if X = 0 then + Result := Y + else // Y > X, X <> 0, so Y > 0 + Result := Y * Sqrt(1 + Sqr(X/Y)); +end; +} +asm + FLD Y + FABS + FLD X + FABS + FCOM + FNSTSW AX + TEST AH,$45 + JNZ @@1 // if ST > ST(1) then swap + FXCH ST(1) // put larger number in ST(1) +@@1: FLDZ + FCOMP + FNSTSW AX + TEST AH,$40 // if ST = 0, return ST(1) + JZ @@2 + FSTP ST // eat ST(0) + JMP @@3 +@@2: FDIV ST,ST(1) // ST := ST / ST(1) + FMUL ST,ST // ST := ST * ST + FLD1 + FADD // ST := ST + 1 + FSQRT // ST := Sqrt(ST) + FMUL // ST(1) := ST * ST(1); Pop ST +@@3: FWAIT +end; + + +procedure SinCos(Theta: Extended; var Sin, Cos: Extended); +asm + FLD Theta + FSINCOS + FSTP tbyte ptr [edx] // Cos + FSTP tbyte ptr [eax] // Sin + FWAIT +end; + +{ Extract exponent and mantissa from X } +procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer); +{ Mantissa ptr in EAX, Exponent ptr in EDX } +asm + FLD X + PUSH EAX + MOV dword ptr [edx], 0 { if X = 0, return 0 } + + FTST + FSTSW AX + FWAIT + SAHF + JZ @@Done + + FXTRACT // ST(1) = exponent, (pushed) ST = fraction + FXCH + +// The FXTRACT instruction normalizes the fraction 1 bit higher than +// wanted for the definition of frexp() so we need to tweak the result +// by scaling the fraction down and incrementing the exponent. + + FISTP dword ptr [edx] + FLD1 + FCHS + FXCH + FSCALE // scale fraction + INC dword ptr [edx] // exponent biased to match + FSTP ST(1) // discard -1, leave fraction as TOS + +@@Done: + POP EAX + FSTP tbyte ptr [eax] + FWAIT +end; + +function Ldexp(X: Extended; P: Integer): Extended; + { Result := X * (2^P) } +asm + PUSH EAX + FILD dword ptr [ESP] + FLD X + FSCALE + POP EAX + FSTP ST(1) + FWAIT +end; + +function Ceil(X: Extended): Integer; +begin + Result := Integer(Trunc(X)); + if Frac(X) > 0 then + Inc(Result); +end; + +function Floor(X: Extended): Integer; +begin + Result := Integer(Trunc(X)); + if Frac(X) < 0 then + Dec(Result); +end; + +{ Conversion of bases: Log.b(X) = Log.a(X) / Log.a(b) } + +function Log10(X: Extended): Extended; + { Log.10(X) := Log.2(X) * Log.10(2) } +asm + FLDLG2 { Log base ten of 2 } + FLD X + FYL2X + FWAIT +end; + +function Log2(X: Extended): Extended; +asm + FLD1 + FLD X + FYL2X + FWAIT +end; + +function LogN(Base, X: Extended): Extended; +{ Log.N(X) := Log.2(X) / Log.2(N) } +asm + FLD1 + FLD X + FYL2X + FLD1 + FLD Base + FYL2X + FDIV + FWAIT +end; + +function Poly(X: Extended; const Coefficients: array of Double): Extended; +{ Horner's method } +var + I: Integer; +begin + Result := Coefficients[High(Coefficients)]; + for I := High(Coefficients)-1 downto Low(Coefficients) do + Result := Result * X + Coefficients[I]; +end; + +function Power(Base, Exponent: Extended): Extended; +begin + if Exponent = 0.0 then + Result := 1.0 { n**0 = 1 } + else if (Base = 0.0) and (Exponent > 0.0) then + Result := 0.0 { 0**n = 0, n > 0 } + else if (Frac(Exponent) = 0.0) and (EAbs(Exponent) <= MaxInt) then + Result := IntPower(Base, Integer(Trunc(Exponent))) + else + Result := Exp(Exponent * Ln(Base)) +end; + +{$IFNDEF _D6orHigher} +(*function Trunc1( X: Extended ): Int64; +begin + Result := System.Trunc( X ); +end; +asm + FLD qword ptr [ESP+4] + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end;*) + +function Trunc( X: Extended ): Int64; +begin + if Abs( X ) < 1 then Result := 0 else + if X < 0 then Result := -System.Trunc( -X ) + else Result := System.Trunc( X ); +end; +{$ENDIF} + + +{ Hyperbolic functions } + +function CoshSinh(X: Extended; Factor: Double): Extended; +begin + Result := Exp(X) / 2; + Result := Result + Factor / Result; +end; + +function Cosh(X: Extended): Extended; +begin + Result := CoshSinh(X, 0.25) +end; + +function Sinh(X: Extended): Extended; +begin + Result := CoshSinh(X, -0.25) +end; + +const + MaxTanhDomain = 5678.22249441322; // Ln(MaxExtended)/2 + +function Tanh(X: Extended): Extended; +begin + if X > MaxTanhDomain then + Result := 1.0 + else if X < -MaxTanhDomain then + Result := -1.0 + else + begin + Result := Exp(X); + Result := Result * Result; + Result := (Result - 1.0) / (Result + 1.0) + end; +end; + +function ArcCosh(X: Extended): Extended; +begin + if X <= 1.0 then + Result := 0.0 + else if X > 1.0e10 then + Result := Ln(2) + Ln(X) + else + Result := Ln(X + Sqrt((X - 1.0) * (X + 1.0))); +end; + +function ArcSinh(X: Extended): Extended; +var + Neg: Boolean; +begin + if X = 0 then + Result := 0 + else + begin + Neg := (X < 0); + X := EAbs(X); + if X > 1.0e10 then + Result := Ln(2) + Ln(X) + else + begin + Result := X*X; + Result := LnXP1(X + Result / (1 + Sqrt(1 + Result))); + end; + if Neg then Result := -Result; + end; +end; + +function ArcTanh(X: Extended): Extended; +var + Neg: Boolean; +begin + if X = 0 then + Result := 0 + else + begin + Neg := (X < 0); + X := EAbs(X); + if X >= 1 then + Result := MaxExtended + else + Result := 0.5 * LnXP1((2.0 * X) / (1.0 - X)); + if Neg then Result := -Result; + end; +end; + +{ Statistical functions } + +function Mean(const Data: array of Double): Extended; +begin + Result := SUM(Data) / (High(Data) - Low(Data) + 1) +end; + +function MinValue(const Data: array of Double): Double; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result > Data[I] then + Result := Data[I]; +end; + +function MinIntValue(const Data: array of Integer): Integer; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result > Data[I] then + Result := Data[I]; +end; + +function Min(A,B: Integer): Integer; +begin + if A < B then + Result := A + else + Result := B; +end; + +{$IFDEF _D4orHigher} +function Min(A,B: I64): I64; +begin + if Cmp64( A, B ) < 0 then + Result := A + else + Result := B; +end; + +function Min(A,B: Int64): Int64; +begin + if A < B then + Result := A + else + Result := B; +end; + +function Min(A,B: Single): Single; +begin + if A < B then + Result := A + else + Result := B; +end; + +function Min(A,B: Double): Double; +begin + if A < B then + Result := A + else + Result := B; +end; + +function Min(A,B: Extended): Extended; +begin + if A < B then + Result := A + else + Result := B; +end; +{$ENDIF} + +function MaxValue(const Data: array of Double): Double; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result < Data[I] then + Result := Data[I]; +end; + +function MaxIntValue(const Data: array of Integer): Integer; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result < Data[I] then + Result := Data[I]; +end; + +function Max(A,B: Integer): Integer; +begin + if A > B then + Result := A + else + Result := B; +end; + +{$IFDEF _D4orHigher} +function Max(A,B: I64): I64; +begin + if Cmp64( A, B ) > 0 then + Result := A + else + Result := B; +end; + +function Max(A,B: Single): Single; +begin + if A > B then + Result := A + else + Result := B; +end; + +function Max(A,B: Double): Double; +begin + if A > B then + Result := A + else + Result := B; +end; + +function Max(A,B: Extended): Extended; +begin + if A > B then + Result := A + else + Result := B; +end; +{$ENDIF} + +procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); +var + S: Extended; + N,I: Integer; +begin + N := High(Data)- Low(Data) + 1; + if N = 1 then + begin + Mean := Data[0]; + StdDev := Data[0]; + Exit; + end; + Mean := Sum(Data) / N; + S := 0; // sum differences from the mean, for greater accuracy + for I := Low(Data) to High(Data) do + S := S + Sqr(Mean - Data[I]); + StdDev := Sqrt(S / (N - 1)); +end; + +procedure MomentSkewKurtosis(const Data: array of Double; + var M1, M2, M3, M4, Skew, Kurtosis: Extended); +var + Sum, SumSquares, SumCubes, SumQuads, OverN, Accum, M1Sqr, S2N, S3N: Extended; + I: Integer; +begin + OverN := 1 / (High(Data) - Low(Data) + 1); + Sum := 0; + SumSquares := 0; + SumCubes := 0; + SumQuads := 0; + for I := Low(Data) to High(Data) do + begin + Sum := Sum + Data[I]; + Accum := Sqr(Data[I]); + SumSquares := SumSquares + Accum; + Accum := Accum*Data[I]; + SumCubes := SumCubes + Accum; + SumQuads := SumQuads + Accum*Data[I]; + end; + M1 := Sum * OverN; + M1Sqr := Sqr(M1); + S2N := SumSquares * OverN; + S3N := SumCubes * OverN; + M2 := S2N - M1Sqr; + M3 := S3N - (M1 * 3 * S2N) + 2*M1Sqr*M1; + M4 := (SumQuads * OverN) - (M1 * 4 * S3N) + (M1Sqr*6*S2N - 3*Sqr(M1Sqr)); + Skew := M3 * Power(M2, -3/2); // = M3 / Power(M2, 3/2) + Kurtosis := M4 / Sqr(M2); +end; + +function Norm(const Data: array of Double): Extended; +begin + Result := Sqrt(SumOfSquares(Data)); +end; + +function PopnStdDev(const Data: array of Double): Extended; +begin + Result := Sqrt(PopnVariance(Data)) +end; + +function PopnVariance(const Data: array of Double): Extended; +begin + Result := TotalVariance(Data) / (High(Data) - Low(Data) + 1) +end; + +function RandG(Mean, StdDev: Extended): Extended; +{ Marsaglia-Bray algorithm } +var + U1, S2: Extended; +begin + repeat + U1 := 2*Random - 1; + S2 := Sqr(U1) + Sqr(2*Random-1); + until S2 < 1; + Result := Sqrt(-2*Ln(S2)/S2) * U1 * StdDev + Mean; +end; + +function StdDev(const Data: array of Double): Extended; +begin + Result := Sqrt(Variance(Data)) +end; + +procedure RaiseOverflowError; forward; + +function SumInt(const Data: array of Integer): Integer; +{var + I: Integer; +begin + Result := 0; + for I := Low(Data) to High(Data) do + Result := Result + Data[I] +end; } +asm // IN: EAX = ptr to Data, EDX = High(Data) = Count - 1 + // loop unrolled 4 times, 5 clocks per loop, 1.2 clocks per datum + PUSH EBX + MOV ECX, EAX // ecx = ptr to data + MOV EBX, EDX + XOR EAX, EAX + AND EDX, not 3 + AND EBX, 3 + SHL EDX, 2 + JMP @Vector.Pointer[EBX*4] +@Vector: + DD @@1 + DD @@2 + DD @@3 + DD @@4 +@@4: + ADD EAX, [ECX+12+EDX] + JO RaiseOverflowError +@@3: + ADD EAX, [ECX+8+EDX] + JO RaiseOverflowError +@@2: + ADD EAX, [ECX+4+EDX] + JO RaiseOverflowError +@@1: + ADD EAX, [ECX+EDX] + JO RaiseOverflowError + SUB EDX,16 + JNS @@4 + POP EBX +end; + +procedure RaiseOverflowError; +begin + raise Exception.Create(e_IntOverflow, SIntOverflow); +end; + +function SUM(const Data: array of Double): Extended; +{var + I: Integer; +begin + Result := 0.0; + for I := Low(Data) to High(Data) do + Result := Result + Data[I] +end; } +asm // IN: EAX = ptr to Data, EDX = High(Data) = Count - 1 + // Uses 4 accumulators to minimize read-after-write delays and loop overhead + // 5 clocks per loop, 4 items per loop = 1.2 clocks per item + FLDZ + MOV ECX, EDX + FLD ST(0) + AND EDX, not 3 + FLD ST(0) + AND ECX, 3 + FLD ST(0) + SHL EDX, 3 // count * sizeof(Double) = count * 8 + JMP @Vector.Pointer[ECX*4] +@Vector: + DD @@1 + DD @@2 + DD @@3 + DD @@4 +@@4: FADD qword ptr [EAX+EDX+24] // 1 + FXCH ST(3) // 0 +@@3: FADD qword ptr [EAX+EDX+16] // 1 + FXCH ST(2) // 0 +@@2: FADD qword ptr [EAX+EDX+8] // 1 + FXCH ST(1) // 0 +@@1: FADD qword ptr [EAX+EDX] // 1 + FXCH ST(2) // 0 + SUB EDX, 32 + JNS @@4 + FADDP ST(3),ST // ST(3) := ST + ST(3); Pop ST + FADD // ST(1) := ST + ST(1); Pop ST + FADD // ST(1) := ST + ST(1); Pop ST + FWAIT +end; + +function SumOfSquares(const Data: array of Double): Extended; +var + I: Integer; +begin + Result := 0.0; + for I := Low(Data) to High(Data) do + Result := Result + Sqr(Data[I]); +end; + +procedure SumsAndSquares(const Data: array of Double; var Sum, SumOfSquares: Extended); +{var + I: Integer; +begin + Sum := 0; + SumOfSquares := 0; + for I := Low(Data) to High(Data) do + begin + Sum := Sum + Data[I]; + SumOfSquares := SumOfSquares + Data[I]*Data[I]; + end; +end; } +asm // IN: EAX = ptr to Data + // EDX = High(Data) = Count - 1 + // ECX = ptr to Sum + // Est. 17 clocks per loop, 4 items per loop = 4.5 clocks per data item + FLDZ // init Sum accumulator + PUSH ECX + MOV ECX, EDX + FLD ST(0) // init Sqr1 accum. + AND EDX, not 3 + FLD ST(0) // init Sqr2 accum. + AND ECX, 3 + FLD ST(0) // init/simulate last data item left in ST + SHL EDX, 3 // count * sizeof(Double) = count * 8 + JMP @Vector.Pointer[ECX*4] +@Vector: + DD @@1 + DD @@2 + DD @@3 + DD @@4 +@@4: FADD // Sqr2 := Sqr2 + Sqr(Data4); Pop Data4 + FLD qword ptr [EAX+EDX+24] // Load Data1 + FADD ST(3),ST // Sum := Sum + Data1 + FMUL ST,ST // Data1 := Sqr(Data1) +@@3: FLD qword ptr [EAX+EDX+16] // Load Data2 + FADD ST(4),ST // Sum := Sum + Data2 + FMUL ST,ST // Data2 := Sqr(Data2) + FXCH // Move Sqr(Data1) into ST(0) + FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data1); Pop Data1 +@@2: FLD qword ptr [EAX+EDX+8] // Load Data3 + FADD ST(4),ST // Sum := Sum + Data3 + FMUL ST,ST // Data3 := Sqr(Data3) + FXCH // Move Sqr(Data2) into ST(0) + FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data2); Pop Data2 +@@1: FLD qword ptr [EAX+EDX] // Load Data4 + FADD ST(4),ST // Sum := Sum + Data4 + FMUL ST,ST // Sqr(Data4) + FXCH // Move Sqr(Data3) into ST(0) + FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data3); Pop Data3 + SUB EDX,32 + JNS @@4 + FADD // Sqr2 := Sqr2 + Sqr(Data4); Pop Data4 + POP ECX + FADD // Sqr1 := Sqr2 + Sqr1; Pop Sqr2 + FXCH // Move Sum1 into ST(0) + MOV EAX, SumOfSquares + FSTP tbyte ptr [ECX] // Sum := Sum1; Pop Sum1 + FSTP tbyte ptr [EAX] // SumOfSquares := Sum1; Pop Sum1 + FWAIT +end; + +function TotalVariance(const Data: array of Double): Extended; +var + Sum, SumSquares: Extended; +begin + SumsAndSquares(Data, Sum, SumSquares); + Result := SumSquares - Sqr(Sum)/(High(Data) - Low(Data) + 1); +end; + +function Variance(const Data: array of Double): Extended; +begin + Result := TotalVariance(Data) / (High(Data) - Low(Data)) +end; + + +{ Depreciation functions. } + +function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended; +{ dv := cost * (1 - 2/life)**(period - 1) + DDB = (2/life) * dv + if DDB > dv - salvage then DDB := dv - salvage + if DDB < 0 then DDB := 0 +} +var + DepreciatedVal, Factor: Extended; +begin + Result := 0; + if (Period < 1) or (Life < Period) or (Life < 1) or (Cost <= Salvage) then + Exit; + + {depreciate everything in period 1 if life is only one or two periods} + if ( Life <= 2 ) then + begin + if ( Period = 1 ) then + DoubleDecliningBalance:=Cost-Salvage + else + DoubleDecliningBalance:=0; {all depreciation occurred in first period} + exit; + end; + Factor := 2.0 / Life; + + DepreciatedVal := Cost * IntPower((1.0 - Factor), Period - 1); + {DepreciatedVal is Cost-(sum of previous depreciation results)} + + Result := Factor * DepreciatedVal; + {Nominal computed depreciation for this period. The rest of the + function applies limits to this nominal value. } + + {Only depreciate until total depreciation equals cost-salvage.} + if Result > DepreciatedVal - Salvage then + Result := DepreciatedVal - Salvage; + + {No more depreciation after salvage value is reached. This is mostly a nit. + If Result is negative at this point, it's very close to zero.} + if Result < 0.0 then + Result := 0.0; +end; + +function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended; +{ Spreads depreciation linearly over life. } +begin + if Life < 1 then ArgError('SLNDepreciation'); + Result := (Cost - Salvage) / Life +end; + +function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended; +{ SYD = (cost - salvage) * (life - period + 1) / (life*(life + 1)/2) } +{ Note: life*(life+1)/2 = 1+2+3+...+life "sum of years" + The depreciation factor varies from life/sum_of_years in first period = 1 + downto 1/sum_of_years in last period = life. + Total depreciation over life is cost-salvage.} +var + X1, X2: Extended; +begin + Result := 0; + if (Period < 1) or (Life < Period) or (Cost <= Salvage) then Exit; + X1 := 2 * (Life - Period + 1); + X2 := Life * (Life + 1); + Result := (Cost - Salvage) * X1 / X2 +end; + +{ Discounted cash flow functions. } + +function InternalRateOfReturn(Guess: Extended; const CashFlows: array of Double): Extended; +{ +Use Newton's method to solve NPV = 0, where NPV is a polynomial in +x = 1/(1+rate). Split the coefficients into negative and postive sets: + neg + pos = 0, so pos = -neg, so -neg/pos = 1 +Then solve: + log(-neg/pos) = 0 + + Let t = log(1/(1+r) = -LnXP1(r) + then r = exp(-t) - 1 +Iterate on t, then use the last equation to compute r. +} +var + T, Y: Extended; + Poly: TPoly; + K, Count: Integer; + + function ConditionP(const CashFlows: array of Double): Integer; + { Guarantees existence and uniqueness of root. The sign of payments + must change exactly once, the net payout must be always > 0 for + first portion, then each payment must be >= 0. + Returns: 0 if condition not satisfied, > 0 if condition satisfied + and this is the index of the first value considered a payback. } + var + X: Double; + I, K: Integer; + begin + K := High(CashFlows); + while (K >= 0) and (CashFlows[K] >= 0.0) do Dec(K); + Inc(K); + if K > 0 then + begin + X := 0.0; + I := 0; + while I < K do begin + X := X + CashFlows[I]; + if X >= 0.0 then + begin + K := 0; + Break + end; + Inc(I) + end + end; + ConditionP := K + end; + +begin + InternalRateOfReturn := 0; + K := ConditionP(CashFlows); + if K < 0 then ArgError('InternalRateOfReturn'); + if K = 0 then + begin + if Guess <= -1.0 then ArgError('InternalRateOfReturn'); + T := -LnXP1(Guess) + end else + T := 0.0; + for Count := 1 to MaxIterations do + begin + PolyX(CashFlows, Exp(T), Poly); + if Poly.Pos <= Poly.Neg then ArgError('InternalRateOfReturn'); + if (Poly.Neg >= 0.0) or (Poly.Pos <= 0.0) then + begin + InternalRateOfReturn := -1.0; + Exit; + end; + with Poly do + Y := Ln(-Neg / Pos) / (DNeg / Neg - DPos / Pos); + T := T - Y; + if RelSmall(Y, T) then + begin + InternalRateOfReturn := Exp(-T) - 1.0; + Exit; + end + end; + ArgError('InternalRateOfReturn'); +end; + +function NetPresentValue(Rate: Extended; const CashFlows: array of Double; + PaymentTime: TPaymentTime): Extended; +{ Caution: The sign of NPV is reversed from what would be expected for standard + cash flows!} +var + rr: Extended; + I: Integer; +begin + if Rate <= -1.0 then ArgError('NetPresentValue'); + rr := 1/(1+Rate); + result := 0; + for I := High(CashFlows) downto Low(CashFlows) do + result := rr * result + CashFlows[I]; + if PaymentTime = ptEndOfPeriod then result := rr * result; +end; + +{ Annuity functions. } + +{--------------- +From the point of view of A, amounts received by A are positive and +amounts disbursed by A are negative (e.g. a borrower's loan repayments +are regarded by the borrower as negative). + +Given interest rate r, number of periods n: + compound(r, n) = (1 + r)**n "Compounding growth factor" + annuity(r, n) = (compound(r, n)-1) / r "Annuity growth factor" + +Given future value fv, periodic payment pmt, present value pv and type +of payment (start, 1 , or end of period, 0) pmtTime, financial variables satisfy: + + fv = -pmt*(1 + r*pmtTime)*annuity(r, n) - pv*compound(r, n) + +For fv, pv, pmt: + + C := compound(r, n) + A := (1 + r*pmtTime)*annuity(r, n) + Compute both at once in Annuity2. + + if C > 1E16 then A = C/r, so: + fv := meaningless + pv := -pmt*(pmtTime+1/r) + pmt := -pv*r/(1 + r*pmtTime) + else + fv := -pmt(1+r*pmtTime)*A - pv*C + pv := (-pmt(1+r*pmtTime)*A - fv)/C + pmt := (-pv*C-fv)/((1+r*pmtTime)*A) +---------------} + +function PaymentParts(Period, NPeriods: Integer; Rate, PresentValue, + FutureValue: Extended; PaymentTime: TPaymentTime; var IntPmt: Extended): + Extended; +var + Crn:extended; { =Compound(Rate,NPeriods) } + Crp:extended; { =Compound(Rate,Period-1) } + Arn:extended; { =AnnuityF(Rate,NPeriods) } + +begin + if Rate <= -1.0 then ArgError('PaymentParts'); + Crp:=Compound(Rate,Period-1); + Arn:=Annuity2(Rate,NPeriods,PaymentTime,Crn); + IntPmt:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; + PaymentParts:=(-FutureValue-PresentValue)*Crp/Arn; +end; + +function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: + Extended; PaymentTime: TPaymentTime): Extended; +var + Annuity, CompoundRN: Extended; +begin + if Rate <= -1.0 then ArgError('FutureValue'); + Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); + if CompoundRN > 1.0E16 then ArgError('FutureValue'); + FutureValue := -Payment * Annuity - PresentValue * CompoundRN +end; + +function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue, + FutureValue: Extended; PaymentTime: TPaymentTime): Extended; +var + Crp:extended; { compound(rate,period-1)} + Crn:extended; { compound(rate,nperiods)} + Arn:extended; { annuityf(rate,nperiods)} +begin + if (Rate <= -1.0) + or (Period < 1) or (Period > NPeriods) then ArgError('InterestPayment'); + Crp:=Compound(Rate,Period-1); + Arn:=Annuity2(Rate,Nperiods,PaymentTime,Crn); + InterestPayment:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; +end; + +function InterestRate(NPeriods: Integer; + Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; +{ +Given: + First and last payments are non-zero and of opposite signs. + Number of periods N >= 2. +Convert data into cash flow of first, N-1 payments, last with +first < 0, payment > 0, last > 0. +Compute the IRR of this cash flow: + 0 = first + pmt*x + pmt*x**2 + ... + pmt*x**(N-1) + last*x**N +where x = 1/(1 + rate). +Substitute x = exp(t) and apply Newton's method to + f(t) = log(pmt*x + ... + last*x**N) / -first +which has a unique root given the above hypotheses. +} +var + X, Y, Z, First, Pmt, Last, T, ET, EnT, ET1: Extended; + Count: Integer; + Reverse: Boolean; + + function LostPrecision(X: Extended): Boolean; + asm + XOR EAX, EAX + MOV BX,WORD PTR X+8 + INC EAX + AND EBX, $7FF0 + JZ @@1 + CMP EBX, $7FF0 + JE @@1 + XOR EAX,EAX + @@1: + end; + +begin + Result := 0; + if NPeriods <= 0 then ArgError('InterestRate'); + Pmt := Payment; + if PaymentTime = ptEndOfPeriod then + begin + X := PresentValue; + Y := FutureValue + Payment + end + else + begin + X := PresentValue + Payment; + Y := FutureValue + end; + First := X; + Last := Y; + Reverse := False; + if First * Payment > 0.0 then + begin + Reverse := True; + T := First; + First := Last; + Last := T + end; + if first > 0.0 then + begin + First := -First; + Pmt := -Pmt; + Last := -Last + end; + if (First = 0.0) or (Last < 0.0) then ArgError('InterestRate'); + T := 0.0; { Guess at solution } + for Count := 1 to MaxIterations do + begin + EnT := Exp(NPeriods * T); + if {LostPrecision(EnT)} ent=(ent+1) then + begin + Result := -Pmt / First; + if Reverse then + Result := Exp(-LnXP1(Result)) - 1.0; + Exit; + end; + ET := Exp(T); + ET1 := ET - 1.0; + if ET1 = 0.0 then + begin + X := NPeriods; + Y := X * (X - 1.0) / 2.0 + end + else + begin + X := ET * (Exp((NPeriods - 1) * T)-1.0) / ET1; + Y := (NPeriods * EnT - ET - X * ET) / ET1 + end; + Z := Pmt * X + Last * EnT; + Y := Ln(Z / -First) / ((Pmt * Y + Last * NPeriods *EnT) / Z); + T := T - Y; + if RelSmall(Y, T) then + begin + if not Reverse then T := -T; + InterestRate := Exp(T)-1.0; + Exit; + end + end; + ArgError('InterestRate'); +end; + +function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended; + PaymentTime: TPaymentTime): Extended; + +{ If Rate = 0 then nper := -(pv + fv) / pmt + else cf := pv + pmt * (1 + rate*pmtTime) / rate + nper := LnXP1(-(pv + fv) / cf) / LnXP1(rate) } + +var + PVRPP: Extended; { =PV*Rate+Payment } {"initial cash flow"} + T: Extended; + +begin + + if Rate <= -1.0 then ArgError('NumberOfPeriods'); + +{whenever both Payment and PaymentTime are given together, the PaymentTime has the effect + of modifying the effective Payment by the interest accrued on the Payment} + + if ( PaymentTime=ptStartOfPeriod ) then + Payment:=Payment*(1+Rate); + +{if the payment exactly matches the interest accrued periodically on the + presentvalue, then an infinite number of payments are going to be + required to effect a change from presentvalue to futurevalue. The + following catches that specific error where payment is exactly equal, + but opposite in sign to the interest on the present value. If PVRPP + ("initial cash flow") is simply close to zero, the computation will + be numerically unstable, but not as likely to cause an error.} + + PVRPP:=PresentValue*Rate+Payment; + if PVRPP=0 then ArgError('NumberOfPeriods'); + + { 6.1E-5 approx= 2**-14 } + if ( EAbs(Rate)<6.1E-5 ) then + Result:=-(PresentValue+FutureValue)/PVRPP + else + begin + +{starting with the initial cash flow, each compounding period cash flow + should result in the current value approaching the final value. The + following test combines a number of simultaneous conditions to ensure + reasonableness of the cashflow before computing the NPER.} + + T:= -(PresentValue+FutureValue)*Rate/PVRPP; + if T<=-1.0 then ArgError('NumberOfPeriods'); + Result := LnXP1(T) / LnXP1(Rate) + end; + NumberOfPeriods:=Result; +end; + +function Payment(Rate: Extended; NPeriods: Integer; PresentValue, FutureValue: + Extended; PaymentTime: TPaymentTime): Extended; +var + Annuity, CompoundRN: Extended; +begin + if Rate <= -1.0 then ArgError('Payment'); + Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); + if CompoundRN > 1.0E16 then + Payment := -PresentValue * Rate / (1 + Integer(PaymentTime) * Rate) + else + Payment := (-PresentValue * CompoundRN - FutureValue) / Annuity +end; + +function PeriodPayment(Rate: Extended; Period, NPeriods: Integer; + PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; +var + Junk: Extended; +begin + if (Rate <= -1.0) or (Period < 1) or (Period > NPeriods) then ArgError('PeriodPayment'); + PeriodPayment := PaymentParts(Period, NPeriods, Rate, PresentValue, + FutureValue, PaymentTime, Junk); +end; + +function PresentValue(Rate: Extended; NPeriods: Integer; Payment, FutureValue: + Extended; PaymentTime: TPaymentTime): Extended; +var + Annuity, CompoundRN: Extended; +begin + if Rate <= -1.0 then ArgError('PresentValue'); + Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); + if CompoundRN > 1.0E16 then + PresentValue := -(Payment / Rate * Integer(PaymentTime) * Payment) + else + PresentValue := (-Payment * Annuity - FutureValue) / CompoundRN +end; + +{------------------------------------------------------------------------------} + +function IsPowerOf2( i: Integer ): Boolean; { Result = (i <> 0) and (i and (i-1) = 0); } +asm + OR EAX,EAX + JZ @@exit // 0 не является степенью числа 2 + LEA EDX, [EAX-1] + OR EAX,EDX + SETZ AL // число является степенью 2, если (i & (i-1)) = 0, т.е. если после + // обнуления младшей 1 в числе больше не осталось битов 1. +@@exit: +end; + +function Low1( i: Integer ): Integer; { Result := i and (-i); } +asm + MOV EDX, EAX + NEG EAX + AND EAX, EDX +end; + +function Low0( i: Integer ): Integer; { Result := -i and (i+1); } +asm + LEA EDX, [EAX+1] + NEG EAX + AND EAX, EDX +end; + +function count_1_bits_in_byte( x: Byte ): Byte; + asm + MOV CL, AL +@@loop: + SHR CL, 1 + JZ @@exit + SUB AL, CL + JMP @@loop +@@exit: + end; + +function count_1_bits_in_dword( x: Integer ): Integer; + asm + MOV ECX, EAX + JMP @@go +@@loop: + SUB EAX, ECX +@@go: + SHR ECX, 1 + JNZ @@loop + end; + +end. diff --git a/Addons/KOLPageSetupDialog.pas b/Addons/KOLPageSetupDialog.pas new file mode 100644 index 0000000..1470887 --- /dev/null +++ b/Addons/KOLPageSetupDialog.pas @@ -0,0 +1,409 @@ +unit KOLPageSetupDialog; +{* Page setup dialog. +|
+Ver 1.4 +|
+Now the information about selected printer can be transferred to TKOLPrinter. +If DC is needed directly use new psdReturnDC option. +|
+Note :page setup dialog replace print dialog marked as obsolete by Microsoft. +|
Bad news is that this dialog do not return printer DC. In TKOLPageSetupDialog +DC is constructed from returned values, but margins should be processed by application. +(or assigned to TKOLPrinter ;-) 17-09-2002 B.Brandys) +|
+Note: +|
+- when custom page is selected ,DC is empty (bug?) +|
+- application must process margins (but it is simple as AssignMargins to TKOlPrinter ;-) + + } + +interface + +uses Windows, Messages, KOL, KOLPrintCommon; + + +const + + DN_DEFAULTPRN = $0001; {default printer } + HELPMSGSTRING = 'commdlg_help'; + +//****************************************************************************** +// PageSetupDlg options +//****************************************************************************** + + PSD_DEFAULTMINMARGINS = $00000000; + PSD_INWININIINTLMEASURE = $00000000; + PSD_MINMARGINS = $00000001; + PSD_MARGINS = $00000002; + PSD_INTHOUSANDTHSOFINCHES = $00000004; + PSD_INHUNDREDTHSOFMILLIMETERS = $00000008; + PSD_DISABLEMARGINS = $00000010; + PSD_DISABLEPRINTER = $00000020; + PSD_NOWARNING = $00000080; + PSD_DISABLEORIENTATION = $00000100; + PSD_RETURNDEFAULT = $00000400; + PSD_DISABLEPAPER = $00000200; + PSD_SHOWHELP = $00000800; + PSD_ENABLEPAGESETUPHOOK = $00002000; + PSD_ENABLEPAGESETUPTEMPLATE = $00008000; + PSD_ENABLEPAGESETUPTEMPLATEHANDLE = $00020000; + PSD_ENABLEPAGEPAINTHOOK = $00040000; + PSD_DISABLEPAGEPAINTING = $00080000; + PSD_NONETWORKBUTTON = $00200000; + +//****************************************************************************** +// Error constants +//****************************************************************************** + + + CDERR_DIALOGFAILURE = $FFFF; + CDERR_GENERALCODES = $0000; + CDERR_STRUCTSIZE = $0001; + CDERR_INITIALIZATION = $0002; + CDERR_NOTEMPLATE = $0003; + CDERR_NOHINSTANCE = $0004; + CDERR_LOADSTRFAILURE = $0005; + CDERR_FINDRESFAILURE = $0006; + CDERR_LOADRESFAILURE = $0007; + CDERR_LOCKRESFAILURE = $0008; + CDERR_MEMALLOCFAILURE = $0009; + CDERR_MEMLOCKFAILURE = $000A; + CDERR_NOHOOK = $000B; + CDERR_REGISTERMSGFAIL = $000C; + PDERR_PRINTERCODES = $1000; + PDERR_SETUPFAILURE = $1001; + PDERR_PARSEFAILURE = $1002; + PDERR_RETDEFFAILURE = $1003; + PDERR_LOADDRVFAILURE = $1004; + PDERR_GETDEVMODEFAIL = $1005; + PDERR_INITFAILURE = $1006; + PDERR_NODEVICES = $1007; + PDERR_NODEFAULTPRN = $1008; + PDERR_DNDMMISMATCH = $1009; + PDERR_CREATEICFAILURE = $100A; + PDERR_PRINTERNOTFOUND = $100B; + PDERR_DEFAULTDIFFERENT = $100C; + + +type + + + + { Structure for PageSetupDlg function } + PtagPSD = ^tagPSD; + tagPSD = packed record + {* Structure for PageSetupDlg function } + lStructSize: DWORD; + hwndOwner: HWND; + hDevMode: HGLOBAL; + hDevNames: HGLOBAL; + Flags: DWORD; + ptPaperSize: TPoint; + rtMinMargin: TRect; + rtMargin: TRect; + hInstance: HINST; + lCustData: LPARAM; + lpfnPageSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpfnPagePaintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpPageSetupTemplateName: PAnsiChar; + hPageSetupTemplate: HGLOBAL; + end; + + + + + + + + + + +function PageSetupDlg(var PgSetupDialog: tagPSD): BOOL; stdcall;external 'comdlg32.dll' + name {$IFDEF UNICODE_CTRLS} 'PageSetupDlgW' {$ELSE} 'PageSetupDlgA' {$ENDIF}; + +function CommDlgExtendedError():DWORD;stdcall; external 'comdlg32.dll' + name 'CommDlgExtendedError'; + + + + + + + + + + + + + + + + + +////////////////////////////////////////////////////// +// // +// Page setup dialog. // +// // +////////////////////////////////////////////////////// + + + +type +TPageSetupOption = (psdMargins,psdOrientation,psdSamplePage,psdPaperControl,psdPrinterControl, +psdHundredthsOfMillimeters,psdThousandthsOfInches,psdUseMargins,psdUseMinMargins,psdWarning,psdHelp,psdReturnDC); +TPageSetupOptions = Set of TPageSetupOption; +{* Options: +|
+|
  • psdMargins : allow user to select margins
    • +|
  • psdOrientation : allow user to select page orientation
    • +|
  • psdSamplePage : draw contents of the sample page
    • +|
  • psdPaperControl : allow paper size control
    • +|
  • psdPrinterControl : allow user to select printer
    • +|
  • psdHundredthsOfMillimeters : set scale to hundredths of millimeters for margins and paper size,on return indicate selected scale
    • +|
  • psdThousandthsOfInches : set scale to thousandths of inches for margins and paper size,on return indicate selected scale
    • +|
  • psdUseMargins,psdUseMinMargins : use suggested margins
    • +|
  • psdWarning : generate warning when there is no default printer
    • +|
  • psdHelp : add help button to dialog, application must process HELPMSGSTRING message
    • +|
  • psdReturnDC : returns DC of selected printer if required
    • +|
+ } + + PPageSetupDlg = ^TPageSetupDlg; + TKOLPageSetupDialog = PPageSetupDlg; + TPageSetupDlg = object(TObj) + {*} + private + { Private declarations } + fhDC : HDC; + fAdvanced : WORD; + ftagPSD : tagPSD; + fOptions : TPageSetupOptions; + fDevNames : PDevNames; + PrinterInfo : TPrinterInfo; + protected + function GetError : Integer; + {*} + { Protected declarations } + public + { Public declarations } + destructor Destroy; virtual; + property Error : Integer read GetError; + {* Returns extended error (which is not the same as error returned from GetLastError) + |
+ Note : if You want error descriptions each error is defined in this file source + } + function GetPaperSize : TPoint; + {*} + procedure SetMinMargins(Left,Top,Right,Bottom: Integer); + {*} + function GetMinMargins : TRect; + {*} + procedure SetMargins(Left,Top,Right,Bottom : Integer); + {*} + function GetMargins : TRect; + {*} + property Options : TPageSetupOptions read fOptions write fOptions; + {* Set of dialog options} + property DC : hDC read fhDC; + {*} + function Execute : Boolean; + {*} + function Info : PPrinterInfo; + {* Return info about selected printer.Can be used by TKOLPrinter} + {These below are usefull in Advanced mode } + property tagPSD : tagPSD read ftagPSD write ftagPSD; + {* For low-level access} + property Advanced : WORD read fAdvanced write fAdvanced; + {* 0 := default + |
+ 1 := You must assign properties to tagPSD.Flags by yourself + |
+ 2 := You can create DEVNAMES and DEVMODE structures and assign to object tagPSD + (but also You must free previous tagPSD.hDevMode and tagPSD.hDevNames) + } + procedure FillOptions(DlgOptions : TPageSetupOptions); + {* } + procedure Prepare; + {* Destroy of previous allocated DEVMODE , DEVNAMES and DC. Is always invoked on destroy and in Execute method (when Advanced :=0 of course).} + end; + +function NewPageSetupDialog(AOwner : PControl; Options : TPageSetupOptions) : PPageSetupDlg; +{* Global function for page setup dialog} + +implementation + + + + +////////////////////////////////////////////////////// +// // +// Page setup dialog (implementation) // +// // +////////////////////////////////////////////////////// + + + + + +function NewPageSetupDialog(AOwner : PControl; Options : TPageSetupOptions) : PPageSetupDlg; +begin + New(Result,Create); + FillChar(Result.ftagPSD,sizeof(tagPSD),0); + Result.ftagPSD.hWndOwner := AOwner.GetWindowHandle; + Result.ftagPSD.hInstance := hInstance; + Result.fOptions := Options; + Result.fAdvanced :=0; + Result.fhDC := 0; +end; + + +destructor TPageSetupDlg.Destroy; +begin + Prepare; + inherited; +end; + +procedure TPageSetupDlg.Prepare; +begin + if ftagPSD.hDevMode <> 0 then + begin + GlobalUnlock(ftagPSD.hDevMode); + GlobalFree(ftagPSD.hDevMode); + ftagPSD.hDevMode :=0; + end; + if ftagPSD.hDevNames <> 0 then + begin + GlobalUnlock(ftagPSD.hDevNames); + GlobalFree(ftagPSD.hDevNames); + ftagPSD.hDevNames :=0; + end; + if fhDC <> 0 then + begin + DeleteDC(fhDC); + fhDC :=0; + end; +end; + + +procedure TPageSetupDlg.FillOptions(DlgOptions : TPageSetupOptions); +begin + ftagPSD.Flags := PSD_DEFAULTMINMARGINS; + { Disable some parts of PageSetup window } + if not (psdMargins in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEMARGINS); + if not (psdOrientation in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEORIENTATION); + if not (psdSamplePage in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEPAGEPAINTING); + if not (psdPaperControl in DlgOptions) then Inc(ftagPSD.Flags,PSD_DISABLEPAPER); + if not (psdPrinterControl in DlgOptions) then inc(ftagPSD.Flags,PSD_DISABLEPRINTER); + { Process HELPMSGSTRING message. Note : AOwner control must register and + process this message.} + if psdHelp in DlgOptions then Inc(ftagPSD.Flags, PSD_SHOWHELP); + { Disable warning if there is no default printer } + if not (psdWarning in DlgOptions) then Inc(ftagPSD.Flags, PSD_NOWARNING); + if psdHundredthsOfMillimeters in DlgOptions then Inc(ftagPSD.Flags,PSD_INHUNDREDTHSOFMILLIMETERS); + if psdThousandthsOfInches in DlgOptions then Inc(ftagPSD.Flags,PSD_INTHOUSANDTHSOFINCHES); + if psdUseMargins in Dlgoptions then Inc(ftagPSD.Flags,PSD_MARGINS); + if psdUseMinMargins in DlgOptions then Inc(ftagPSD.Flags,PSD_MINMARGINS); + +end; + +function TPageSetupDlg.GetError : Integer; +begin + Result := CommDlgExtendedError(); +end; + +function TPageSetupDlg.Execute : Boolean; +var +ExitCode : Boolean; +Device,Driver,Output : PChar; +fDevMode : PDevMode; +begin + case fAdvanced of + 0 : //Not in advanced mode + begin + Prepare; + FillOptions(fOptions); + end; + 1:Prepare; //Advanced mode . User must assign properties and/or hook procedures + end; //If Advanced > 1 then You are expert ! (better use pure API ;-)) + ftagPSD.lStructSize := sizeof(tagPSD); + ExitCode := PageSetupDlg(ftagPSD); + if (ftagPSD.Flags and PSD_INHUNDREDTHSOFMILLIMETERS) <> 0 then + fOptions := fOptions + [psdHundredthsOfMillimeters] + else + fOptions := fOptions - [psdHundredthsOfMillimeters]; + + if (ftagPSD.Flags and PSD_INTHOUSANDTHSOFINCHES) <> 0 then + fOptions := fOptions + [psdThousandthsOfInches] + else + fOptions := fOptions - [psdThousandthsOfInches]; + fDevNames := PDevNames(GlobalLock(ftagPSD.hDevNames)); + fDevMode := PDevMode(GlobalLock(ftagPSD.hDevMode)); + if fDevNames <> nil then //support situation when user pressed cancel button + begin + Driver := PChar(fDevNames) + fDevNames^.wDriverOffset; + Device := PChar(fDevNames) + fDevNames^.wDeviceOffset; + Output := PChar(fDevNames) + fDevNames^.wOutputOffset; + if psdReturnDC in fOptions then fhDC := CreateDC(Driver,Device,Output,fDevMode); + end; + Result := ExitCode; +end; + +function TPageSetupDlg.Info : PPrinterInfo; +begin + try + FillChar(PrinterInfo,sizeof(PrinterInfo),0); + with PrinterInfo do + begin + if fDevNames <> nil then + begin + ADriver := PChar(fDevNames) + fDevNames^.wDriverOffset; + ADevice := PChar(fDevNames) + fDevNames^.wDeviceOffset; + APort := PChar(fDevNames) + fDevNames^.wOutputOffset; + end; + ADevMode := ftagPSD.hDevMode; + end; + finally // support fDevNames=0 (user pressed Cancel) + Result := @PrinterInfo; + end; +end; + + + + +function TPageSetupDlg.GetPaperSize : TPoint; +begin + Result := ftagPSD.ptPaperSize; +end; + +procedure TPageSetupDlg.SetMinMargins(Left,Top,Right,Bottom: Integer); +begin + ftagPSD.rtMinMargin.Left := Left; + ftagPSD.rtMinMargin.Top := Top; + ftagPSD.rtMinMargin.Right := Right; + ftagPSD.rtMinMargin.Bottom := Bottom; +end; + +function TPageSetupDlg.GetMinMargins : TRect; +begin + Result := ftagPSD.rtMinMargin; +end; + +procedure TPageSetupDlg.SetMargins(Left,Top,Right,Bottom : Integer); +begin + ftagPSD.rtMargin.Left := Left; + ftagPSD.rtMargin.Top := Top; + ftagPSD.rtMargin.Right := Right; + ftagPSD.rtMargin.Bottom := Bottom; +end; + +function TPageSetupDlg.GetMargins : TRect; +begin + Result := ftagPSD.rtMargin; +end; + + + +begin +end. diff --git a/Addons/KOLPcx.pas b/Addons/KOLPcx.pas new file mode 100644 index 0000000..fa0a040 --- /dev/null +++ b/Addons/KOLPcx.pas @@ -0,0 +1,364 @@ +unit KOLPcx; +{* PCX - PC Paintbrush format (ZSoft) support for KOL. + (C) by Kladov Vladimir 30-Sep-2002 + ( bonanzas@xcl.cjb.net, http://xcl.cjb.net ) + v1.0 - reading PCX only (it is converted to DIB bitmap when loaded) +} + +interface + +{$RANGECHECKS OFF} + +uses + Windows, KOL; + + +type + TRGBPixel = packed record + R, G, B: Byte; + end; + + PPCXHeader = ^TPCXHeader; + TPCXHeader = packed record + Manufacturer : Byte; //Постоянный флаг 10 = ZSoft .PCX + Version : Byte; //0 = Версия 2.5 + //2 = Версия 2.8 с информацией о палитре + //3 = Версия 2.8 без информации о палитре + //5 = Версия 3.0 + Encoding : Byte; //1 = .PCX кодирование длинными сериями + BitsPerPixel : Byte; //Число бит на пиксел в слое + Xmin : Word; //Размеры изображения (Xmin, Ymin) - (Xmax, Ymax) в пикселах включительно + Ymin : Word; + Xmax : Word; + Ymax : Word; + Hres : Word; //Горизонтальное разрешение создающего устройства + Vres : Word; //Вертикальное разрешение создающего устройства + ColorMap : array[ 0..15 ] of TRGBPixel; + Reserved : Byte; + NPlanes : Byte; //Число цветовых слоев + BytesPerLine : Word; //Число байт на строку в цветовом слое + //(для PCX-файлов всегда должно быть четным) + PaletteInfo : Byte; //Как интерпретировать палитру: + //1 = цветная/черно-белая, + //2 = градации серого + Filler : array[ 0..58 ] of Byte; // нули + end; + + PPCX = ^TPCX; + TPCX = object( TObj ) + {* PCX implementation object} + protected + //FError: TPCXError; + FBitmap: PBitmap; + protected + {Returns image width and height} + function GetWidth: Integer; + function GetHeight: Integer; + {Returns if the image is empty} + function GetEmpty: Boolean; + public + procedure Clear; + {Draws the image into a canvas} + procedure Draw(DC: HDC; X, Y: Integer); + procedure StretchDraw( DC: HDC; const Rect: TRect ); + {Width and height properties} + property Width: Integer read GetWidth; + property Height: Integer read GetHeight; + {Property to return if the image is empty or not} + property Empty: Boolean read GetEmpty; + {Object being created and destroyed} + destructor Destroy; virtual; + function LoadFromFile(const Filename: String): Boolean; + //procedure SaveToFile(const Filename: String); + function LoadFromStream(Stream: PStream): Boolean; + //procedure SaveToStream(Stream: PStream); + {Loading the image from resources} + function LoadFromResourceName(Instance: HInst; const Name: String): Boolean; + function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; + {} + property Bitmap: PBitmap read FBitmap; + end; + +function NewPCX: PPCX; + +implementation + +function NewPCX: PPCX; +begin + new( Result, Create ); +end; + +{ TPCX } + +procedure TPCX.Clear; +begin + Free_And_Nil( FBitmap ); +end; + +destructor TPCX.Destroy; +begin + FBitmap.Free; + inherited; +end; + +procedure TPCX.Draw(DC: HDC; X, Y: Integer); +begin + if Empty then Exit; + FBitmap.Draw( DC, X, Y ); +end; + +function TPCX.GetEmpty: Boolean; +begin + Result := (FBitmap=nil) or FBitmap.Empty; +end; + +function TPCX.GetHeight: Integer; +begin + if Empty then + Result := 0 + else + Result := FBitmap.Height; +end; + +function TPCX.GetWidth: Integer; +begin + if Empty then + Result := 0 + else + Result := FBitmap.Width; +end; + +function TPCX.LoadFromFile(const Filename: String): Boolean; +var Strm: PStream; +begin + Strm := NewReadFileStream( Filename ); + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TPCX.LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TPCX.LoadFromResourceName(Instance: HInst; const Name: String): Boolean; +var Strm: PStream; +begin + Strm := NewMemoryStream; + Resource2Stream( Strm, Instance, PChar( Name ), RT_RCDATA ); + Strm.Position := 0; + Result := LoadFromStream( Strm ); + Strm.Free; +end; + +function TPCX.LoadFromStream(Stream: PStream): Boolean; +type + TRGBPixelExt = packed record + Pixel: TRGBPixel; + Dummy: Byte; + end; +var + StartPos: DWORD; + + procedure Decode; + var Header: TPCXHeader; + Format: TPixelFormat; + Buffer, Dest, Src, SrcBuf: PByte; + W, H, ImgSize, I, BitIdx, X, SrcSize: Integer; + B, B1, B2, B3, B4: Byte; + RGBPixelExt: TRGBPixelExt; + begin + Result := FALSE; + Clear; + if Stream.Read( Header, Sizeof( Header ) ) < Sizeof( Header ) then Exit; + if Header.Manufacturer <> 10 then Exit; + if (Header.BitsPerPixel = 1) and (Header.NPlanes = 1) then + Format := pf1bit + else + if (Header.BitsPerPixel = 1) and (Header.NPlanes = 4) or + (Header.BitsPerPixel = 4) and (Header.NPlanes = 1) then + Format := pf4bit + else + if (Header.BitsPerPixel = 8) and (Header.NPlanes = 1) then + Format := pf8bit + else + if (Header.BitsPerPixel = 8) and (Header.NPlanes = 3) then + Format := pf24bit + else + Exit; + + W := Header.Xmax - Header.Xmin + 1; + H := Header.Ymax - Header.Ymin + 1; + ImgSize := Header.NPlanes * Header.BytesPerLine * H; + GetMem( Buffer, ImgSize ); + if Buffer = nil then Exit; + + //-------------------- декодирование ---------------------- + SrcSize := Stream.Size - Stream.Position; + if SrcSize > ImgSize * 2 then + SrcSize := ImgSize * 2; + GetMem( SrcBuf, SrcSize ); + SrcSize := Stream.Read( SrcBuf^, SrcSize ); + Src := SrcBuf; + Dest := Buffer; + while (DWORD( Dest ) < DWORD( Buffer ) + DWORD( ImgSize ) ) and + (DWORD( Src ) < DWORD( SrcBuf ) + DWORD( SrcSize ) ) do + begin + //Stream.Read( B, 1 ); + B := Src^; Inc( Src ); + if B >= $C0 then + begin + I := B and $3F; + //Stream.Read( B, 1 ); + B := Src^; Inc( Src ); + for I := I-1 downto 0 do + begin + Dest^ := B; Inc( Dest ); + end; + end + else + begin + Dest^ := B; Inc( Dest ); + end; + end; + //Stream.Position := StartPos + Sizeof( Header ) + DWORD( Src ) - DWORD( SrcBuf ); + FreeMem( SrcBuf ); + + FBitmap := NewDIBBitmap( W, H, Format ); + //-------------------- формирование изображения ------------------------ + if (Format = pf4bit) and (Header.NPlanes = 4) then + begin + for I := 0 to H-1 do + begin + Dest := FBitmap.ScanLine[ I ]; + BitIdx := 8; + B1 := 0; B2 := 0; B3 := 0; B4 := 0; + Src := Pointer( Integer( Buffer ) + Header.BytesPerLine * 4 * I ); + for X := 0 to W div 2 - 1 do + begin + if BitIdx >= 8 then + begin + BitIdx := 0; + B1 := Src^; + B2 := PByte( Integer( Src ) + Header.BytesPerLine )^; + B3 := PByte( Integer( Src ) + Header.BytesPerLine * 2 )^; + B4 := PByte( Integer( Src ) + Header.BytesPerLine * 3 )^; + Inc( Src ); + end; + B := ((B1 and $80) shr 3) or ((B2 and $80) shr 2) or ((B3 and $80) shr 1) or (B4 and $80) + or ((B1 and $40) shr 6) or ((B2 and $40) shr 5) or ((B3 and $40) shr 4) or ((B4 and $40) shr 3); + B1 := B1 shl 2; + B2 := B2 shl 2; + B3 := B3 shl 2; + B4 := B4 shl 2; + Dest^ := B; + Inc( Dest ); + Inc( BitIdx, 2 ); + end; + end; // конец загрузки 16-цветного изображения по слоям + end + else + if Format = pf24bit then + begin + for I := 0 to H-1 do + begin + Dest := FBitmap.ScanLine[ I ]; + Src := PByte( Integer( Buffer ) + Header.BytesPerLine * 3 * I ); + for X := 0 to W-1 do + begin + B1 := Src^; + B2 := PByte( Integer( Src ) + Header.BytesPerLine )^; + B3 := PByte( Integer( Src ) + Header.BytesPerLine*2 )^; + Dest^ := B3; Inc( Dest ); + Dest^ := B2; Inc( Dest ); + Dest^ := B1; Inc( Dest ); + Inc( Src ); + end; + end; // конец загрузки монохромного, 256-цветного изображения + end + else + //if (Format in [pf8bit,pf1bit]) or ((Format = pf4bit) and (Header.NPlanes = 1)) then + begin + Src := Buffer; + for I := 0 to H-1 do + begin + Dest := FBitmap.ScanLine[ I ]; + Move( Src^, Dest^, Header.BytesPerLine ); + if Format = pf4bit then + begin + for X := 0 to W div 2 - 1 do + begin + B := Dest^; + B := ((B and $11) shl 2) or ((B and $44) shr 2) or + (B and $AA); + Dest^ := B; + Inc( Dest ); + end; + end; + Inc( Src, Header.BytesPerLine ); + end; // конец загрузки монохромного, 256-цветного изображения или 16-цветного в одном слое + end; + //----------- загрузка палитры ------------------ + if Format = pf8bit then + begin + B := 0; + if Stream.Size > 768 then + begin + Stream.Position := Stream.Size - 769; + Stream.Read( B, 1 ); + end; + if (Header.Version in [2,5]) and (B in [10,12]) then + begin // есть своя палитра, прочитаем + RGBPixelExt.Dummy := 0; + GetMem( SrcBuf, 768 ); + Stream.Read( SrcBuf^, 768 ); + Src := SrcBuf; + for I := 0 to 255 do + begin + RGBPixelExt.Pixel.B := Src^; Inc( Src ); + RGBPixelExt.Pixel.G := Src^; Inc( Src ); + RGBPixelExt.Pixel.R := Src^; Inc( Src ); + if B = 10 then + begin + RGBPixelExt.Pixel.R := RGBPixelExt.Pixel.R shl 2; + RGBPixelExt.Pixel.G := RGBPixelExt.Pixel.G shl 2; + RGBPixelExt.Pixel.B := RGBPixelExt.Pixel.B shl 2; + end; + FBitmap.DIBPalEntries[ I ] := Integer( RGBPixelExt ); + end; + FreeMem( SrcBuf ); + end; + end + else + if Format in [pf1bit, pf4bit] then + begin // загрузка палитры для 16-цветных или монохромных изображений + RGBPixelExt.Dummy := 0; + for I := 0 to FBitmap.DIBPalEntryCount-1 do + begin + RGBPixelExt.Pixel := Header.ColorMap[ I ]; + B := RGBPixelExt.Pixel.R; + RGBPixelExt.Pixel.R := RGBPixelExt.Pixel.B; + RGBPixelExt.Pixel.B := B; + FBitmap.DIBPalEntries[ I ] := Integer( RGBPixelExt ); + end; + end; + FreeMem( Buffer ); + Result := TRUE; + end; +begin + StartPos:= Stream.Position; + Decode; + If Result = False Then Stream.Position:= StartPos; +end; + +procedure TPCX.StretchDraw(DC: HDC; const Rect: TRect); +begin + If Empty = False Then FBitmap.StretchDraw( DC, Rect ); +end; + +end. diff --git a/Addons/KOLPrintCommon.pas b/Addons/KOLPrintCommon.pas new file mode 100644 index 0000000..1943486 --- /dev/null +++ b/Addons/KOLPrintCommon.pas @@ -0,0 +1,30 @@ +unit KOLPrintCommon; +{*} + +interface + +uses Windows; + +type + PDevNames = ^tagDEVNAMES; + tagDEVNAMES = packed record + wDriverOffset: Word; + wDeviceOffset: Word; + wOutputOffset: Word; + wDefault: Word; + end; + + PPrinterInfo = ^TPrinterInfo; + TPrinterInfo = packed record + {* Used for transferring information between Print/Page dialogs and TKOLPrinter.This way TKOLPrinter and Print/Page dialogs could be used separately} + ADevice : PChar; + ADriver : PChar; + APort : PChar; + ADevMode : THandle; + end; + + +implementation + +end. + \ No newline at end of file diff --git a/Addons/KOLPrintDialogs.pas b/Addons/KOLPrintDialogs.pas new file mode 100644 index 0000000..a38409c --- /dev/null +++ b/Addons/KOLPrintDialogs.pas @@ -0,0 +1,373 @@ +unit KOLPrintDialogs; +{* Print and printer setup dialogs, implemented in KOL object. +|
+Ver 1.4 +|
+Now the information about selected printer can be transferred to TKOLPrinter. +If DC is needed directly use new pdReturnDC option.} + +interface + +uses Windows, Messages, KOL, KOLPrintCommon; + + +const + + DN_DEFAULTPRN = $0001; {default printer } + HELPMSGSTRING = 'commdlg_help'; + + + +//****************************************************************************** +// PrintDlg options +//****************************************************************************** + + PD_ALLPAGES = $00000000; + PD_SELECTION = $00000001; + PD_PAGENUMS = $00000002; + PD_NOSELECTION = $00000004; + PD_NOPAGENUMS = $00000008; + PD_COLLATE = $00000010; + PD_PRINTTOFILE = $00000020; + PD_PRINTSETUP = $00000040; + PD_NOWARNING = $00000080; + PD_RETURNDC = $00000100; + PD_RETURNIC = $00000200; + PD_RETURNDEFAULT = $00000400; + PD_SHOWHELP = $00000800; + PD_ENABLEPRINTHOOK = $00001000; + PD_ENABLESETUPHOOK = $00002000; + PD_ENABLEPRINTTEMPLATE = $00004000; + PD_ENABLESETUPTEMPLATE = $00008000; + PD_ENABLEPRINTTEMPLATEHANDLE = $00010000; + PD_ENABLESETUPTEMPLATEHANDLE = $00020000; + PD_USEDEVMODECOPIES = $00040000; + PD_USEDEVMODECOPIESANDCOLLATE = $00040000; + PD_DISABLEPRINTTOFILE = $00080000; + PD_HIDEPRINTTOFILE = $00100000; + PD_NONETWORKBUTTON = $00200000; + + +//****************************************************************************** +// Error constants +//****************************************************************************** + + + CDERR_DIALOGFAILURE = $FFFF; + CDERR_GENERALCODES = $0000; + CDERR_STRUCTSIZE = $0001; + CDERR_INITIALIZATION = $0002; + CDERR_NOTEMPLATE = $0003; + CDERR_NOHINSTANCE = $0004; + CDERR_LOADSTRFAILURE = $0005; + CDERR_FINDRESFAILURE = $0006; + CDERR_LOADRESFAILURE = $0007; + CDERR_LOCKRESFAILURE = $0008; + CDERR_MEMALLOCFAILURE = $0009; + CDERR_MEMLOCKFAILURE = $000A; + CDERR_NOHOOK = $000B; + CDERR_REGISTERMSGFAIL = $000C; + PDERR_PRINTERCODES = $1000; + PDERR_SETUPFAILURE = $1001; + PDERR_PARSEFAILURE = $1002; + PDERR_RETDEFFAILURE = $1003; + PDERR_LOADDRVFAILURE = $1004; + PDERR_GETDEVMODEFAIL = $1005; + PDERR_INITFAILURE = $1006; + PDERR_NODEVICES = $1007; + PDERR_NODEFAULTPRN = $1008; + PDERR_DNDMMISMATCH = $1009; + PDERR_CREATEICFAILURE = $100A; + PDERR_PRINTERNOTFOUND = $100B; + PDERR_DEFAULTDIFFERENT = $100C; + + +type + + PDevNames = ^tagDEVNAMES; + tagDEVNAMES = packed record + {*} + wDriverOffset: Word; + wDeviceOffset: Word; + wOutputOffset: Word; + wDefault: Word; + end; + + + + + + + + + { Structure for PrintDlg function } + PtagPD = ^tagPD; + tagPD = packed record + {*} + lStructSize: DWORD; + hWndOwner: HWND; + hDevMode: HGLOBAL; + hDevNames: HGLOBAL; + hDC: HDC; + Flags: DWORD; + nFromPage: Word; + nToPage: Word; + nMinPage: Word; + nMaxPage: Word; + nCopies: Word; + hInstance: HINST; + lCustData: LPARAM; + lpfnPrintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpfnSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpPrintTemplateName: PAnsiChar; + lpSetupTemplateName: PAnsiChar; + hPrintTemplate: HGLOBAL; + hSetupTemplate: HGLOBAL; + end; + + + + + + + + + +function PrintDlg(var PrintDlg: tagPD): BOOL; stdcall;external 'comdlg32.dll' name 'PrintDlgA'; + +function CommDlgExtendedError():DWORD;stdcall; external 'comdlg32.dll' name 'CommDlgExtendedError'; + + + + + + + + + + + + + + + +type + +////////////////////////////////////////////////////// +// // +// Print dialog and printer setup dialog. // +// // +////////////////////////////////////////////////////// + +TPrintDlgOption = (pdPrinterSetup,pdCollate,pdPrintToFile,pdPageNums,pdSelection, +pdWarning,pdDeviceDepend,pdHelp,pdReturnDC); +{* Options: +|
+|
    +|
  • pdPrinterSetup : printer setup dialog
    • +|
  • pdCollate : places checkmark in Collate check box.When Execute returns this flag +indicates that the user selected the Collate option but printer does not support it +|
    • +|
  • pdPrintToFile : causes "Print to File" check box to be visible.When Execute returns this flag +indicates that this check box was selected and must be processed +|
    • +|
  • pdPageNums : allow to select pages in dialog
    • +|
  • pdSelection : set Selection field visible in dialog
    • +|
  • pdWarning : when set, and there's no default printer in system, warning is generated (like in VCL TPrintDialog)
    • +|
  • pdDeviceDepend : disables fields : Copies,Collate if this functions aren't supported by printer driver
    • +|
  • pdHelp : Help button is visible (owner receive HELPMSGSTRING registered message)
    • +|
  • pdReturnDC : returns DC of selected printer
    • +|
+} + + +TPrintDlgOptions = Set of TPrintDlgOption; +{*} + + PPrintDlg =^TPrintDlg; + TKOLPrintDialog = PPrintDlg; + TPrintDlg = object(TObj) + {*} + private + { Private declarations } + fDevNames : PDevNames; + fAdvanced : WORD; + ftagPD : tagPD; + fOptions : TPrintDlgOptions; + PrinterInfo : TPrinterInfo; + protected + function GetError : Integer; + + { Protected declarations } + public + { Public declarations } + destructor Destroy; virtual; + property Error : Integer read GetError; + {* Extended error} + property FromPage : WORD read ftagPD.nFromPage write ftagPD.nFromPage; + {* Starting page } + property ToPage : WORD read ftagPD.nToPage write ftagPD.nToPage; + {* Ending page} + property MinPage : WORD read ftagPD.nMinPage write ftagPD.nMinPage; + {* Minimal page number which is allowed to select} + property MaxPage : WORD read ftagPD.nMaxPage write ftagPD.nMaxPage; + {* Maximal page number which is allowed to select} + property Copies : WORD read ftagPD.nCopies write ftagPD.nCopies; + {* Number of copies} + property Options : TPrintDlgOptions read fOptions write fOptions; + {* Set of options} + property DC : hDC read ftagPD.hDC; + {* DC of selected printer} + function Execute : Boolean; + {* Main method} + function Info : PPrinterInfo; + {*} + {These below are usefull in Advanced mode } + property tagPD : tagPD read ftagPD write ftagPD; + {* For low-level access} + property Advanced : WORD read fAdvanced write fAdvanced; + {* 1 := You must assign properties to tagPD by yourself + |
+ 2 := Even more control... + } + procedure FillOptions(DlgOptions : TPrintDlgOptions); + {* Fill options} + procedure Prepare; + {* Destroy of prevoius context (DEVMODE,DEVNAMES,DC) .Usefull when Advanced > 0} + end; + +function NewPrintDialog(AOwner : PControl; Options : TPrintDlgOptions) : PPrintDlg; +{* Global creating function} + + + + +implementation + + + + + +/////////////////////////////////////////////////////////////// +// // +// Print dialog and printer setup dialog (implementation) // +// // +/////////////////////////////////////////////////////////////// + + + + +function NewPrintDialog(AOwner : PControl; Options : TPrintDlgOptions) : PPrintDlg; +begin + New(Result,Create); + FillChar(Result.ftagPD,sizeof(tagPD),0); + Result.ftagPD.hWndOwner := AOwner.GetWindowHandle; + Result.ftagPD.hInstance := hInstance; + Result.fOptions := Options; + Result.fAdvanced := 0; +end; + + + + + + + +destructor TPrintDlg.Destroy; +begin + Prepare; + inherited; +end; + +procedure TPrintDlg.Prepare; +begin + if ftagPD.hDevMode <> 0 then + begin + GlobalFree(ftagPD.hDevMode); + ftagPD.hDevMode :=0; + end; + if ftagPD.hDevNames <> 0 then + begin + GlobalUnlock(ftagPD.hDevNames); + GlobalFree(ftagPD.hDevNames); + ftagPD.hDevNames :=0; + end; + if ftagPD.hDC <> 0 then + begin + DeleteDC(ftagPD.hDC); + ftagPD.hDC :=0; + end; +end; + + +procedure TPrintDlg.FillOptions(DlgOptions : TPrintDlgOptions); +begin + ftagPD.Flags := PD_ALLPAGES; + { Return HDC if required} + if pdReturnDC in DlgOptions then Inc(ftagPD.Flags,PD_RETURNDC); + { Show printer setup dialog } + if pdPrinterSetup in DlgOptions then Inc(ftagPD.Flags,PD_PRINTSETUP); + { Process HELPMSGSTRING message. Note : AOwner control must register and + process this message.} + if pdHelp in DlgOptions then Inc(ftagPD.Flags, PD_SHOWHELP); + { This flag indicates on return that printer driver does not support collation. + You must eigther provide collation or set pdDeviceDepend (and user won't see + collate checkbox if is not supported) } + if pdCollate in DlgOptions then Inc(ftagPD.Flags,PD_COLLATE); + { Disable some parts of PrintDlg window } + if not (pdPrintToFile in DlgOptions) then Inc(ftagPD.Flags, PD_HIDEPRINTTOFILE); + if not (pdPageNums in DlgOptions) then Inc(ftagPD.Flags, PD_NOPAGENUMS); + if not (pdSelection in DlgOptions) then Inc(ftagPD.Flags, PD_NOSELECTION); + { Disable warning if there is no default printer } + if not (pdWarning in DlgOptions) then Inc(ftagPD.Flags, PD_NOWARNING); + if pdDeviceDepend in DlgOptions then Inc(ftagPD.Flags,PD_USEDEVMODECOPIESANDCOLLATE); + +end; + +function TPrintDlg.GetError : Integer; +begin + Result := CommDlgExtendedError(); +end; + +function TPrintDlg.Execute : Boolean; +var +ExitCode : Boolean; +begin + case fAdvanced of + 0 : //Not in advanced mode + begin + Prepare; + FillOptions(fOptions); + end; + 1:Prepare; //Advanced mode . User must assign properties and/or hook procedures + end; + ftagPD.lStructSize := sizeof(tagPD); + ExitCode := PrintDlg(ftagPD); + fDevNames := PDevNames(GlobalLock(ftagPD.hDevNames)); + if (ftagPD.Flags and PD_PRINTTOFILE) <> 0 then fOptions := fOptions + [pdPrintToFile] + else + fOptions := fOptions - [pdPrintToFile]; + if (ftagPD.Flags and PD_COLLATE) <> 0 then fOptions := fOptions + [pdCollate] + else + fOptions := fOptions - [pdCollate]; + Result := ExitCode; +end; + +function TPrintDlg.Info : PPrinterInfo; +begin + try + FillChar(PrinterInfo,sizeof(PrinterInfo),0); + with PrinterInfo do + begin + ADriver := PChar(fDevNames) + fDevNames^.wDriverOffset; + ADevice := PChar(fDevNames) + fDevNames^.wDeviceOffset; + APort := PChar(fDevNames) + fDevNames^.wOutputOffset; + ADevMode := ftagPD.hDevMode ; + end; + finally //support situation when fDevNames=0 (user pressed Cancel) + Result := @PrinterInfo; + end; +end; + +begin +end. diff --git a/Addons/KOLPrinters.pas b/Addons/KOLPrinters.pas new file mode 100644 index 0000000..f1e11e1 --- /dev/null +++ b/Addons/KOLPrinters.pas @@ -0,0 +1,663 @@ +unit KOLPrinters; +{* Replaces VCL TPrinter functionality. +|
+Author : Bogusіaw Brandys, +|
+|

Version 1.4

+|
+|History : +|
+| 17-09-2002 [+] Added property Assigned which should always be checked before first access +to TKOLPrinter. If is FALSE then there is no printer in system. (Warning: if You +assign incorrect info to Assign procedure this could lead Your application to +crash rather then return Assigned = FALSE) +|
+[+] Changed Write to WriteLn and improved.Now always print a line of text with +carrage return #10#13 even there is no one at the end of text.Also should not break +word on bottom-right corner of page and working good when text does not fit on page +(NextPage invoked) +|
+|
+| 15-09-2002 [-] Fix access violation when there is no printer in system (caused +by DefPrinter function and Assign procedure). +|
+|Example: +! with Printer^ do +! begin +! Assign(nil); //default printer (actually not needed as default printer is assigned on start) +! if not Assigned then begin +! MsgBox('There is no default printer in system!',mb_iconexclamation); +! Exit; +! end; +! Title := 'Printing test...'; +! Canvas.Font.Assign(Memo1.Font); +! BeginDoc; +! for i:=0 to Memo1.Count-1 do WriteLn(Memo1.Items[i]); //or just WriteLn(Memo1.Text); +! EndDoc; +! end; +|
+|One more note: +|
use psdWarning and pdWarning in PageSetup/Print dialogs to let +user know that there is no printer in system (or no default). +When these options are not used PrintDialog appear empty but PageSetup dialog never +appears. +|
+Notes: +|
+When output is redirected to a file and You want to know his name , check Output property +but always after sucessful Execute and before EndDoc (becouse EndDoc clears Output property) +Margins are supported but experimental (if You have time and paper please examine +if it working and let me know ;-) - especially if units for margins are properly computed. +Beside let me know what is still missing... +|
+Still missing (I suppose): +|
+- printing text as continuation of current printed line (in the middle of the line) +(this was a nightmare for me , if You know how to do it contact me) +|
+- printing of selected pages only (must compute pages count) +|
+- collate and printing more than one page when printer do not support multiple pages and collation +(well, should not be very difficult, maybe just check if this is supported and if no just print many times + the same) +|
+- Printers property (list of printers in system),PrinterIndex and Fonts property +|
+- print preview +|
+- more tests} + +interface + +uses Windows,Messages,KOL,KOLPrintCommon; + +type +TPrinterState = (psNeedHandle,psHandle,psOtherHandle); +TPrinterOrientation = (poPortrait,poLandscape); +{* Paper orientation} +TMarginOption = (mgInches,mgMillimeters); +{* Margin option} + + PPrinter =^TPrinter; + TKOLPrinter = PPrinter; + TPrinter = object(TObj) + {*} + private + { Private declarations } + fDevice,fDriver,fPort : String; + fDevMode : THandle; + fDeviceMode : PDeviceMode; + fCanvas : PCanvas; // KOL canvas + fTitle : String; + fState : TPrinterState; // DC is allocated or need new DC becouse params were changed + fAborted : Boolean; + fPrinting : Boolean; + fPageNumber : Integer; + fOutput : String; + PrinterInfo : TPrinterInfo; + fRec : TRect; + fMargins : TRect; //Margins (in pixels) + fAssigned : Boolean; //if TRUE ,there is a printer with correctly assigned information + protected + function GetHandle : HDC; + procedure SetHandle(Value : HDC); + function GetCanvas : PCanvas; + function GetCopies : Integer; + procedure SetCopies(const Value : Integer); + function GetOrientation : TPrinterOrientation; + procedure SetOrientation(const Value : TPrinterOrientation); + function GetPageHeight : Integer; + function GetPageWidth : Integer; + function Scale : Integer; + procedure Prepare; + procedure DefPrinter; + public + { Public declarations } + destructor Destroy; virtual; + procedure Abort; + {* Abort print process} + procedure BeginDoc; + {* Begin print process} + procedure EndDoc; + {* End print process end send it to print spooler} + procedure NewPage; + {* Request new page} + procedure Assign(Source : PPrinterInfo); + {* Assign information about selected printer for example from Print/Page dialogs} + procedure AssignMargins(cMargins : TRect; Option : TMarginOption); + {* Assign information about paper margins for example from TKOLPageSetupDialog + (in thousands of inches scale)} + procedure WriteLn(const Text : String); + {* Print tekst with TKOLPrinter selected font.Note: can be invoked more than once, but currently + only for text ended with #10#13 (other is not properly wraped around right page corner ;-( )} + procedure RE_Print(RichEdit : PControl); + {* Print content of TKOLRichEdit (if Rich is not TKOLRichEdit nothing happens) + with full formating of course :-)} + property Assigned : Boolean read fAssigned; + {* If TRUE, there is a default or assigned previoulsy printer (by Assign).Always check + this property to avoid access violation when there is no printer in system} + property Title : String read fTitle write fTitle; + {* Title of print process in print manager window} + function Info : PPrinterInfo; + {* Returns info of selected print} + property Output : String read fOutput write fOutput; + {* Let print to the file.Assign file path to this property.} + property Handle : HDC read GetHandle write SetHandle; + {*} + property Canvas : PCanvas read GetCanvas; + {*} + property Copies : Integer read GetCopies write SetCopies; + {* Number of copies} + property Orientation : TPrinterOrientation read GetOrientation write SetOrientation; + {* Page orientation} + property Margins : TRect read fMargins write fMargins; + {* Page margins (in pixels)} + property PageHeight : Integer read GetPageHeight; + {* Page height in logical pixels} + property PageWidth : Integer read GetPageWidth; + {* Page width in logical pixels} + property PageNumber : Integer read fPageNumber; + {* Currently printed page number} + property Printing : Boolean read fPrinting; + {* Indicate printing process} + property Aborted : Boolean read fAborted; + {* Indicate abort of printing process} + + end; + + +function Printer : PPrinter; +{* Returns pointer to global TKOLPrinter object} +procedure RecreatePrinter; +{* Recreates global Printer pbject } + +function NewPrinter(PrinterInfo : PPrinterInfo) : PPrinter; +{* Global function for creating TKOLPrinter instance.Usually not needed, becouse +inluding KOLPrinters causes creating of global TKOLPrinter instance.} + + + +implementation +uses RichEdit; + +type + + PtagPD = ^tagPD; + tagPD = packed record + lStructSize: DWORD; + hWndOwner: HWND; + hDevMode: HGLOBAL; + hDevNames: HGLOBAL; + hDC: HDC; + Flags: DWORD; + nFromPage: Word; + nToPage: Word; + nMinPage: Word; + nMaxPage: Word; + nCopies: Word; + hInstance: HINST; + lCustData: LPARAM; + lpfnPrintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpfnSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; + lpPrintTemplateName: PAnsiChar; + lpSetupTemplateName: PAnsiChar; + hPrintTemplate: HGLOBAL; + hSetupTemplate: HGLOBAL; + end; + +const + PD_RETURNDC = $00000100; + PD_RETURNDEFAULT = $00000400; + + + +var +FPrinter : PPrinter = nil; + +function PrintDlg(var PrintDlg: tagPD): BOOL; stdcall;external 'comdlg32.dll' name 'PrintDlgA'; + + + + + + +function AbortProc(Handle : HDC; Error : Integer) : Bool ; stdcall; +begin + Result := not fPrinter.Aborted; +end; + +function NewPrinter(PrinterInfo : PPrinterInfo) : PPrinter; +begin + New(Result,Create); + Result.fTitle := ''; + Result.fOutput := ''; + Result.fAborted := False; + Result.fPrinting := False; + Result.fPageNumber := 0; + Result.fCanvas := nil; + Result.fMargins.Top := 10; + Result.fMargins.Left := 10; + Result.fMargins.Bottom := 10; + Result.fMargins.Right := 10; + FillChar(Result.fRec,sizeof(Result.fRec),0); + if PrinterInfo = nil then Result.DefPrinter + else + Result.Assign(PrinterInfo); + +end; + + +function Printer : PPrinter; +begin + if FPrinter = nil then + FPrinter := NewPrinter(nil); + Result := FPrinter; +end; + +procedure RecreatePrinter; +begin + Free_And_Nil( FPrinter ); + FPrinter := NewPrinter(nil); +end; + + + +destructor TPrinter.Destroy; +begin + Prepare; + fTitle := ''; + fDevice := ''; + fDriver := ''; + fPort := ''; + fOutput := ''; + inherited; {+++} + FPrinter := nil; +end; + +procedure TPrinter.Prepare; +begin + { Free previously used resources } + if (fState <> psOtherHandle) and (fCanvas <> nil) then + begin + fCanvas.Free; + fCanvas := nil; {+++} + end; + if fDevMode <> 0 then + begin + GlobalUnlock(fDevMode); + GlobalFree(fDevMode); + end; +end; + +function TPrinter.Scale : Integer; +var +DC : HDC; +ScreenH,PrinterH : Integer; +begin + DC := GetDC(0); + ScreenH := GetDeviceCaps(DC,LOGPIXELSY); + PrinterH := GetDeviceCaps(fCanvas.Handle,LOGPIXELSY); + ReleaseDC(0,DC); + Result := PrinterH div ScreenH; +end; + +procedure TPrinter.WriteLn(const Text : String); +var +OldFontSize,PageH,Size,Len : Integer; +pC : PChar; +Rect : TRect; +Metrics : TTextMetric; +NewText : String; + +procedure ComputeRect; +{ Start from new line.Rect is the rest of page from current new line to the bottom. First probe + how many characters do not fit on this rect.} +begin + Len := 1; + while Windows.DrawText(fCanvas.Handle,pC,Len,Rect,DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) < PageH do + begin + Rect.Right := fRec.Right; //must be, becouse DrawText shorten right corner + Len := Len + 100; + if Len > Size then + begin + Len := Size; + Break; + end; + end; + + { Next : Count backwards to find exact characters which fit on required page rect.} + while Windows.DrawText(fCanvas.Handle,pC,Len,Rect,DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) > PageH do + Len := Len - 1; + + { Find position of last space or line end (#13#10) to not break word + (if possible) on bottom-right corner of the page.Do it only for multipage text (Len<>Size) } + { + if (Len <> Size) and (Len > 0) then begin + Test := Len; + while ((NewText[Test] <> #32) and (NewText[Test]<> #10)) and (Test > 0) do Test := Test -1 ; + if Test > 0 then Len := Test; + end; + } + + { Finally draw it!} + Windows.DrawText(fCanvas.Handle,pC,Len,Rect,DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS); + + +end; + + +begin +if Length(Text) <=0 then Exit; +if Text[Length(Text)] <> #10 then NewText := Text + #13#10 +else +NewText := Text; +pC := PChar(NewText); +Size := Length(NewText); +SetMapMode(fCanvas.Handle,MM_TEXT); +OldFontSize := fCanvas.Font.FontHeight; +fCanvas.Font.FontHeight := fCanvas.Font.FontHeight * Scale; +SelectObject(fCanvas.Handle,fCanvas.Font.Handle); +PageH := GetPageHeight - fMargins.Bottom; +GetTextMetrics(fCanvas.Handle,Metrics); +while Size > 0 do + begin + Rect := fRec; + ComputeRect; + Inc(pC,Len + 1); + Dec(Size,Len + 1); + if (Size > 0) and (fRec.Left <= fMargins.Left) then NewPage; + end; + if (Rect.Bottom > PageH) then begin + NewPage; + Rect.Bottom := 0; + end; + fRec.Top := Rect.Bottom - Metrics.tmHeight; + fRec.Left := fMargins.Left; + fRec.Bottom := PageH; + fCanvas.Font.FontHeight := OldFontSize; + NewText := ''; +end; + + +procedure TPrinter.DefPrinter; +var +ftagPD : tagPD; +DevNames : PDevNames; +begin + fAssigned := false; + fState := psHandle; + Prepare; + { Get DC of default printer } + FillChar(ftagPD,sizeof(tagPD),0); + ftagPD.Flags := PD_RETURNDC + PD_RETURNDEFAULT; + ftagPD.lStructSize := sizeof(ftagPD); + if not PrintDlg(ftagPD) then Exit; + fAssigned := true; + DevNames := PDevNames(GlobalLock(ftagPD.hDevNames)); + fDevMode := ftagPD.hDevMode; + fDeviceMode := PDevMode(GlobalLock(fDevMode)); + try + fDriver := String(PChar(DevNames) + DevNames^.wDriverOffset); + fDevice := String(PChar(DevNames) + DevNames^.wDeviceOffset); + fPort := String(PChar(DevNames) + DevNames^.wOutputOffset); + finally + GlobalUnlock(ftagPD.hDevNames); + GlobalFree(ftagPD.hDevNames); + end; + fCanvas := NewCanvas(ftagPD.hDC); +end; + +procedure TPrinter.Assign(Source : PPrinterInfo); +var +Size : Integer; +DevMode : PDevMode; +fhDC : HDC; +begin + fAssigned := false; + if (Source = nil) or + (Source^.ADriver = nil) and + (Source^.ADevice = nil) and + (Source^.APort = nil) and + (Source^.ADevMode = 0) then DefPrinter + else + begin + Prepare; + fDriver := String(Source^.ADriver); + fDevice := String(Source^.ADevice); + fPort := String(Source^.APort); + DevMode := PDevMode(GlobalLock(Source^.ADevMode)); + try + Size := sizeof(DevMode^); + fDevMode := GlobalAlloc(GHND,Size); + fDeviceMode := PDevMode(GlobalLock(fDevMode)); + CopyMemory(fDeviceMode,DevMode,Size); + fhDC := CreateDC(PChar(fDriver),PChar(fDevice),PChar(fPort),fDeviceMode); + finally + GlobalUnlock(Source^.ADevMode); + end; + fCanvas := NewCanvas(fhDC); + fAssigned := true; + end; +end; + + +procedure TPrinter.AssignMargins(cMargins : TRect;Option : TMarginOption); +var +PH,PW : Integer; +begin + PH := GetDeviceCaps(fCanvas.Handle,LOGPIXELSY); + PW := GetDeviceCaps(fCanvas.Handle,LOGPIXELSX); + case Option of + mgInches: + begin + fMargins.Top := round((cMargins.Top*PH)/1000); + fMargins.Left := round((cMargins.Left*PW)/1000); + fMargins.Bottom := round((cMargins.Bottom*PH)/1000); + fMargins.Right := round((cMargins.Right*PW)/1000); + end; + mgMillimeters: + begin + fMargins.Top := round((cMargins.Top*PH)/2540); + fMargins.Left := round((cMargins.Left*PW)/2540); + fMargins.Bottom := round((cMargins.Bottom*PH)/2540); + fMargins.Right := round((cMargins.Right*PW)/2540); + end; + end; +end; + +procedure TPrinter.Abort; +begin + AbortDoc(fCanvas.Handle); + fAborted := True; + EndDoc; +end; + + +procedure TPrinter.BeginDoc; +var +doc : DOCINFOA; +begin + fRec.Top := fMargins.Top; + fRec.Left := fMargins.Left; + fRec.Right := GetPageWidth - fMargins.Right ; + fRec.Bottom := GetPageHeight - fMargins.Bottom; + fAborted := False; + fPageNumber :=1; + fPrinting := True; + FillChar(doc,sizeof(DOCINFOA),0); + doc.lpszDocName := PChar(fTitle); + if (fOutput <> '') then doc.lpszOutput := PChar(fOutput); + doc.cbSize := sizeof(doc); + SetAbortProc(fCanvas.Handle,AbortProc); + StartDoc(fCanvas.Handle,doc); + StartPage(fCanvas.Handle); +end; + +procedure TPrinter.EndDoc; +begin + EndPage(fCanvas.Handle); + if not fAborted then Windows.EndDoc(fCanvas.Handle); + fAborted := False; + fPageNumber := 0; + fOutPut := ''; + fPrinting := False; +end; + + + + +function TPrinter.GetHandle : HDC; +var +fhDC : HDC; +begin + if (fState = psNeedHandle) and (fCanvas <> nil) then + begin + fCanvas.Free; + fhDC := CreateDC(PChar(fDriver),PChar(fDevice),PChar(fPort),fDeviceMode); + fCanvas := NewCanvas(fhDC); + fState := psHandle; + end; + Result := fCanvas.Handle; +end; + +procedure TPrinter.SetHandle(Value : HDC); +begin + if Value <> fCanvas.Handle then + begin + if fCanvas <> nil then fCanvas.Free; + fCanvas := NewCanvas(Value); + fState := psOtherHandle; + end; +end; + + +function TPrinter.GetCanvas : PCanvas; +begin + GetHandle; + Result := fCanvas; +end; + + +function TPrinter.Info : PPrinterInfo; +begin + with PrinterInfo do begin + ADevice := PChar(fDevice); + ADriver := PChar(fDriver); + APort := PChar(fPort); + ADevMode := fDevMode; + end; + Result := @PrinterInfo; +end; + +function TPrinter.GetCopies : Integer; +begin + Result := fDeviceMode^.dmCopies; +end; + + +procedure TPrinter.SetCopies(const Value : Integer); +begin + fDeviceMode^.dmCopies := Value; +end; + + +function TPrinter.GetOrientation : TPrinterOrientation; +begin + if System.Assigned(fDeviceMode) and (fDeviceMode^.dmOrientation = DMORIENT_PORTRAIT) then + Result := poPortrait + else + Result := poLandscape; +end; + +procedure TPrinter.SetOrientation(const Value : TPrinterOrientation); +const +Orientations : array [TPrinterOrientation] of Integer = (DMORIENT_PORTRAIT,DMORIENT_LANDSCAPE); +begin + fDeviceMode^.dmOrientation := Orientations[Value]; +end; + +function TPrinter.GetPageHeight : Integer; +begin + if fCanvas <> nil then + Result := GetDeviceCaps(fCanvas.Handle,VERTRES) + else Result := 0; +end; + +function TPrinter.GetPageWidth : Integer; +begin + if fCanvas <> nil then + Result := GetDeviceCaps(fCanvas.Handle,HORZRES) + else Result := 0; +end; + +procedure TPrinter.NewPage; +begin + fRec.Top := fMargins.Top; + fRec.Left := fMargins.Left; + fRec.Right := GetPageWidth - fMargins.Right; + fRec.Bottom := GetPageHeight - fMargins.Bottom; + EndPage(fCanvas.Handle); + StartPage(fCanvas.Handle); + SelectObject(fCanvas.Handle,fCanvas.Font.Handle); + Inc(fPageNumber); +end; + + +procedure TPrinter.RE_Print(RichEdit : PControl); +var + Range: TFormatRange; + LastChar, MaxLen, LogX, LogY, OldMap: Integer; + SaveRect: TRect; + TextLenEx: TGetTextLengthEx; +begin + if IndexOfStr(RichEdit.SubClassName,'obj_RichEdit') = -1 then Exit; + FillChar(Range, SizeOf(TFormatRange), 0); + with Range do begin + BeginDoc; + hdc := GetHandle; + hdcTarget := hdc; + LogX := GetDeviceCaps(Handle, LOGPIXELSX); + LogY := GetDeviceCaps(Handle, LOGPIXELSY); + rc.Top := fMargins.Top*1440 div LogY; + rc.Left := fMargins.Left*1440 div LogX; + rc.Right := (GetPageWidth - fMargins.Right) * 1440 div LogX ; + rc.Bottom := (GetPageHeight - fMargins.Bottom) * 1440 div LogY; + rcPage := rc; + SaveRect := rc; + LastChar := 0; +// if RichEdit.Version >= 2 then begin + with TextLenEx do begin + flags := GTL_DEFAULT; + codepage := CP_ACP; + end; + MaxLen := RichEdit.Perform(EM_GETTEXTLENGTHEX, WParam(@TextLenEx), 0); +// end +// else +// MaxLen := Length(RichEdit.RE_Text[ reRTF, True ]); + chrg.cpMax := -1; + OldMap := SetMapMode(hdc, MM_TEXT); + SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer } + try + repeat + rc := SaveRect; + chrg.cpMin := LastChar; + LastChar := SendMessage(RichEdit.Handle, EM_FORMATRANGE, 1, Longint(@Range)); + if (LastChar < MaxLen) and (LastChar <> -1) then NewPage; + until (LastChar >= MaxLen) or (LastChar = -1); + EndDoc; + finally + SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer } + SetMapMode(hdc, OldMap); { restore previous map mode } + end; + end; +end; + + +initialization +//FPrinter := NewPrinter(nil); + +finalization + Free_And_Nil( FPrinter ); +end. + + diff --git a/Addons/KOLProgBar.pas b/Addons/KOLProgBar.pas new file mode 100644 index 0000000..1ead54f --- /dev/null +++ b/Addons/KOLProgBar.pas @@ -0,0 +1,359 @@ +unit KOLProgBar; + +interface + +uses + Windows, Messages, KOL; + +type + + TBevel = (bvUp, bvDown, bvNone); + + PColorProgBar =^TColorProgBar; + TColorProgressBar = PColorProgBar; + TColorProgBar = object(TObj) + private + { Private declarations } + fControl : PControl; + fPosition: integer; + fOldPosit: integer; + fBColor, + fFColor : TColor; + fFirst : boolean; + fBorder : integer; + fParentCl: boolean; + fBevel : TBevel; + fMin, + fMax : integer; + fStr : string; + fFont : PGraphicTool; + fCanvas : PCanvas; + OldWind, + NewWind : longint; + procedure SetFColor(C: TColor); + procedure SetBColor(C: TColor); + procedure SetPos(P: integer); + procedure SetBorder(B: integer); + procedure SetParentCl(B: boolean); + procedure SetBevel(B: TBevel); + procedure SetMin(M: integer); + procedure SetMax(M: integer); + protected + { Protected declarations } + procedure NewWndProc(var Msg: TMessage); + procedure Paint; +{ procedure WMPaint(var Msg: TMessage); message WM_PAINT; + procedure WMSize (var Msg: TMessage); message WM_SIZE; + procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW; + procedure CMParCl(var Msg: TMessage); message CM_PARENTCOLORCHANGED;} + public + destructor Destroy; virtual; + function SetPosition(X, Y: integer): PColorProgBar; overload; + function SetSize(X, Y: integer): PColorProgBar; overload; + function SetAlign(A: TControlAlign): PColorProgBar; overload; + function GetFont: PGraphicTool; + { Public declarations } +{ constructor Create(Owner: TControl); override;} + property Font: PGraphicTool read GetFont; + property FColor: TColor read fFColor write SetFColor; + property BColor: TColor read fBColor write SetBColor; + property Border: integer read fBorder write SetBorder; + property Position: integer read fPosition write SetPos; + property Max: integer read fMax write SetMax; + property Min: integer read fMin write SetMin; + property ParentColor: boolean read fParentCl write SetParentCl; + property Bevel: TBevel read fBevel write SetBevel; + end; + +function NewTColorProgressBar(AOwner: PControl): PColorProgBar; + +implementation + +uses objects; + +function NewTColorProgressBar; +var p: PColorProgBar; + c: PControl; +begin +{ New(Result, Create);} + c := pointer(_NewControl( AOwner, 'STATIC', WS_VISIBLE or WS_CHILD or + SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, + False, nil )); + c.CreateWindow; + New(p, create); + AOwner.Add2AutoFree(p); + p.fControl := c; + p.fFont := NewFont; + p.fCanvas := NewCanvas(GetDC(c.Handle)); + p.fMin := 0; + p.fMax := 100; + p.fFColor := clRed; + p.fBColor := clBtnFace; + p.fBorder := 4; + p.fBevel := bvDown; + p.fFirst := True; + p.fPosition := 50; + p.fFont.FontStyle := [fsBold]; + Result := p; + p.OldWind := GetWindowLong(c.Handle, GWL_WNDPROC); + p.NewWind := LongInt(MakeObjectInstance(p.NewWndProc)); + SetWindowLong(c.Handle, GWL_WNDPROC, p.NewWind); +end; + +destructor TColorProgBar.Destroy; +begin + SetWindowLong(fControl.Handle, GWL_WNDPROC, OldWind); + FreeObjectInstance(Pointer(NewWind)); + fCanvas.Free; + fFont.Free; + inherited; +end; + +function TColorProgBar.SetPosition(X, Y: integer): PColorProgBar; +begin + fControl.Left := X; + fControl.Top := Y; + Result := @self; +end; + +function TColorProgBar.SetSize(X, Y: integer): PColorProgBar; +begin + fControl.Width := X; + fControl.Height := Y; + Result := @self; +end; + +function TColorProgBar.SetAlign(A: TControlAlign): PColorProgBar; +begin + fControl.Align := A; + Result := @self; +end; + +function TColorProgBar.GetFont; +begin + Result := fFont; +end; + + +procedure TColorProgBar.NewWndProc; +begin + Msg.Result := CallWindowProc(Pointer(OldWind), fControl.Handle, Msg.Msg, Msg.wParam, Msg.lParam); + case Msg.Msg of +WM_PAINT: Paint; +WM_SIZE: begin + fFirst := True; + Paint; + end; +WM_ACTIVATE: + begin + fFirst := True; + Paint; + end; +{CM_PARENTCOLORCHANGED: + begin + if fParentCl then begin + if Msg.wParam <> 0 then + BColor := TColor(Msg.lParam) else + BColor := (Parent as TForm).Color; + FColor := (Parent as TForm).Font.Color; + end; + end;} + end; +end; + +procedure TColorProgBar.SetFColor; +begin + fFColor := C; + fFirst := True; + Paint; +end; + +procedure TColorProgBar.SetBColor; +begin + fBColor := C; + fFirst := True; + Paint; +end; + +procedure TColorProgBar.SetPos; +begin + fPosition := P; + Paint; +end; + +procedure TColorProgBar.SetBorder; +begin + fBorder := B; + fFirst := True; + Paint; +end; + +procedure TColorProgBar.SetParentCl; +begin + fParentCl := B; + if B then begin +{ Perform(CM_PARENTCOLORCHANGED, 0, 0);} + Paint; + end; +end; + +procedure TColorProgBar.SetBevel; +begin + fBevel := B; + fFirst := True; + Paint; +end; + +procedure TColorProgBar.SetMin; +begin + fMin := M; + fFirst := True; + if fMax = fMin then fMax := fMin + 1; + Paint; +end; + +procedure TColorProgBar.SetMax; +begin + fMax := M; + fFirst := True; + if fMin = fMax then fMin := fMax - 1; + Paint; +end; + +procedure Frame3D(Canvas: PCanvas; var Rect: TRect; TopColor, BottomColor: TColor; + Width: Integer); + + procedure DoRect; + var + TopRight, BottomLeft: TPoint; + begin + with Canvas^, Rect do + begin + TopRight.X := Right; + TopRight.Y := Top; + BottomLeft.X := Left; + BottomLeft.Y := Bottom; + Pen.Color := TopColor; + PolyLine([BottomLeft, TopLeft, TopRight]); + Pen.Color := BottomColor; + Dec(BottomLeft.X); + PolyLine([TopRight, BottomRight, BottomLeft]); + end; + end; + +begin + Dec(Rect.Bottom); Dec(Rect.Right); + while Width > 0 do + begin + Dec(Width); + DoRect; + InflateRect(Rect, -1, -1); + end; + Inc(Rect.Bottom); Inc(Rect.Right); +end; + +function ColorToRGB(Color: TColor): Longint; +begin + if Color < 0 then + Result := GetSysColor(Color and $000000FF) else + Result := Color; +end; + +procedure TColorProgBar.Paint; +var Rct: TRect; + Trc: TRect; + Twk: TRect; + Str: string; + Rht: integer; + Len: integer; + Rgn: HRgn; + Stw: integer; +begin + GetClientRect(fControl.Handle, Rct); + Trc := Rct; + if (fPosition <= fOldPosit) or fFirst then begin + case fBevel of + bvUp: begin + Frame3D(fCanvas, Rct, clWhite, clBlack, 1); + end; +bvDown: begin + Frame3D(fCanvas, Rct, clBlack, clWhite, 1); + end; + end; + + fFirst := False; + fCanvas.brush.Color := fBColor; + fCanvas.FillRect(Rct); + end; + Rct := Trc; + + InflateRect(Rct, -fBorder, -fBorder); + Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min); + + Str := ' ' + int2str(fPosition * 100 div (fMax - fMin)) + '% '; + + SelectObject(fCanvas.Handle, fFont.Handle); + Stw := fCanvas.TextWidth(Str); + Trc.Left := (fControl.width - Stw) div 2; + Trc.Right := (fControl.width + Stw) div 2 + 1; + Twk := Rct; + + fCanvas.brush.Color := fFColor; + if (Rct.Right <= Trc.Left) then begin + fCanvas.FillRect(Rct); + end else begin + Twk.Right := Trc.Left; + fCanvas.FillRect(Twk); + end; + + Rht := Rct.Right; + Len := Length(Str); + + Rct.Left := (fControl.width - Stw) div 2; + Rct.Right := (fControl.width + Stw) div 2 + 1; + + if fStr <> Str then begin + if (Rct.Right > Rht) or (fCanvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin + Rgn := CreateRectRgn(Rht, Rct.Top, Rct.Right, Rct.Bottom); + SelectClipRgn(fCanvas.Handle, Rgn); + SelectObject(fCanvas.Handle, fFont.Handle); + SetBkColor(fCanvas.Handle, ColorToRGB(fBColor)); + SetTextColor(fCanvas.Handle, ColorToRGB(fFColor)); + DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP or DT_NOCLIP); + SelectClipRgn(fCanvas.Handle, 0); + DeleteObject(Rgn); + end; + end; + + if Rht < Rct.Right then begin + Rct.Right := Rht; + end; + + Dec(Rct.Left); + Inc(Rct.Right); + + if (Rct.Right > Rct.Left) then begin + SelectObject(fCanvas.Handle, fFont.Handle); + SetBkColor(fCanvas.Handle, ColorToRGB(fFColor)); + SetTextColor(fCanvas.Handle, ColorToRGB(fBColor)); + DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP); + if Rct.Right < Trc.Right then begin + Twk := Rct; + Twk.Top := Twk.Top + fCanvas.TextHeight(Str); + fCanvas.brush.Color := fFColor; + fCanvas.Fillrect(Twk); + end; + end; + + if (Rct.Right >= Trc.Right) then begin + Rct.Left := Trc.Right - 2; + Rct.Right := Rht; + SetBkColor(fCanvas.Handle, ColorToRGB(fFColor)); + fCanvas.FillRect(Rct); + end; + + fStr := Str; + fOldPosit := fPosition; +end; + +end. diff --git a/Addons/KOLQProgBar.pas b/Addons/KOLQProgBar.pas new file mode 100644 index 0000000..a01c1fb --- /dev/null +++ b/Addons/KOLQProgBar.pas @@ -0,0 +1,1541 @@ +unit KOLQProgBar; +{ + + ("`-''-/").___..--''"`-._ + `6_ 6 ) `-. ( ).`-.__.`) + (_Y_.)' ._ ) `._ `. ``-..-' + _..`--'_..-_/ /--'_.' ,' +(il).-'' (li).' ((!.-' + + QnnO Progress Bar (KOL) + The component that provides a set of various progress bars. + + Ported to KOL © 2007 Danger + E-Mail: + + Original excellent TQProgressBar VCL component was developed by QnnO + and was ported to KOL with his permission. Merci a Qnno! + Thanks to 'MTsv DN' for his 'standard progress bar' compatibility idea. + +} + + { ****************************************************************** } + { v 1.1 } + { Delphi (6) unit -- progressbar replacement, with } + { several features... } + { } + { Copyright © 2004 by Olivier Touzot "QnnO" } + { (http://mapage.noos.fr/qnno/delphi_en.htm - qnno@noos.fr) } + { } + { ---------------------------------- } + { } + { History : } + { v 1.1 : 2004-05-12 (!) Correction of the "extreme colors" bug in } + { the GetGradientAr2(); function by Bernd Kirchhoff, allowing} + { the use of pure white or black colors in the bars. Thanks } + { and congratulations (he made the work under cbuilder 4.0 !)} + { v 1.0 : 2004-05-11 First release ; } + { ****************************************************************** } + + // This unit is freeware, but under copyrights that remain mine for my + // parts of the code, and original writters for their parts of the code. + // This is mainly the case with : + // -> The polynomial expression of the MakeCylinder(); function, provided + // by Matthieu Contensou, (with lots of help too, on many other + // subjects (see below)). + // (http://www25.brinkster.com/waypointfrance/cpulog/index.asp) + // -> The RGBtoHLS(); and HLStoRGB(); procedures, that come from a + // Microsoft knowledge base article (Q29240), at : + // http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 + // -> The GetColorBetween(); function, which computes the main gradient, + // found at efg's colors page, and which author is saddly unknown : + // http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/Color.htm + // http://homepages.borland.com/efg2lab/Library/UseNet/2001/0821.txt + // -> The GetGradientAr2(); new version, by Bernd Kirchhoff, which now + // correctly handles white and black colors in bars. + // (http://home.germany.net/100-445474/) + + // This unit can be freely used in any application, freeware, shareware + // or commercial. However, I would apreciate your sending me an email if + // you decide to use it. Of course, you use it under your own and single + // responsability. Neither me, nor contributors, could be held responsible + // for any problem resulting from the use of this unit. ;-) + + // It can also be freely distributed, provided all the above (and current) + // lines remain within it unchanged, and the readme.txt file be distributed + // with it too. + + // Many thanks go to Matthieu Contensou, who spent a lot of time (and + // patience ... ) trying to explain me the subtleties of the RGB -> YUV + // and return conversions.) + // He gave the idea of using the HLS space too, which is now used in this + // component. + + {* TKOLQProgressBar is the visual component that provides a set of various progress bars. + Adapted for KOL library, this was designed with maximal usability in mind and looks nice. + Original excellent TQProgressBar VCL component was developed by QnnO and several contributors, + and was ported to KOL with his permission. Merci a Qnno! + |
+  |Copyright (C) 2004 Olivier Touzot "QnnO" and TQProgressBar contributors.
+  |It can be found on the web at http://mapage.noos.fr/qnno/delphi_en.htm.
+  |Copyright (C) 2007 Danger (danger@artline.kz).
+  |
+ |TKOLQProgressBar coming under the form of a KOL library unit, it can be simply used + by creating bars at runtime, setting the necessary properties: + !uses Windows, Messages, KOL, ..., KOLQProgBar; + ! //... + !var aPBar : PQProgressBar; + ! //... + !aPBar := NewQProgressBar( AParentForm ); + !aPBar.Progress:= 55; + !aPBar. ... + |

Certainly you can use the 'MCK mirror' provided with component to manage control properties at design time + (this still actually for Delphi versions earlier than Delphi 2005). In this case the visual component will + draws itself in design time with one of two available painting methods (see Readme.txt for details). + Note that control appearance at design time isn't depends on any of KOLCtrlWrapper routines and uses native VCL stuff. + |

Known problem:
+ It's latency in the drawing of the first of a series of bars. The laging one is the first one updated, if + |ShowInactivePos is set to True, and whatever are it's other characteristics (size, appearence, aso). + The problem appears only under XP (despite a high cpu speed). A workaround is to call + |Form.ProcessMessages just after the change of the position value of the first bar.

+ In the demo, the four vertical bars illustrate this. They should slide all together, but the first one lags, unless + |I add the Form.ProcessMessages like this: + !procedure TForm1.TrackBar2Scroll( Sender: PTrackbar; Code: Integer ); + !begin + ! Form.ProcessMessages; // Avoids the lag. + ! QProgressBar7.Progress:= Sender.Position; + ! QProgressBar8.Progress:= Sender.Position; + ! QProgressBar9.Progress:= Sender.Position; + ! QProgressBar10.Progress:= Sender.Position; + !end; + |

} + +interface +// ---------------------------------------------------------- +uses + Windows, Messages, KOL; + +// ---------------------------------------------------------- +type + TQBarKind = ( bkFlat, bkCylinder ); + {* Progress bar style. } + + TQBarLook = ( blMetal, blGlass ); + {* Progress bar appearance. } + + TQBarOrientation = ( boHorizontal, boVertical ); + {* Visual control orientation. } + + TRGBArray = array[0..2] of Byte; + TCLRArray = array of TColor; + THLSRange = 0..240; + + THLSRec = record // Color conversion -> RgbToHls and return + hue: THLSRange; + lum: THLSRange; + sat: THLSRange; + end; + + TPosDescr = record // Bar description, rows or column ... + isInBlock: Boolean; // ... depending on orientation + blkLimit : Integer; + end; + +// ---------------------------------------------------------- + PQProgressBar = ^TQProgressBar; + TKOLQProgressBar = PQProgressBar; + + TOnQProgressBar = procedure( Sender: PQProgressBar ) of object; + {* |Event to be called when Progress value is changed. } + + PQDataObj = ^TQDataObj; + +// ---------------------------------------------------------- + TQDataObj = object( TObj ) + fPosDescr : array of TPosDescr; // Bar description, blocks and spaces + fPixDescr : array of TCLRArray; // Bar description, pixels colors + fInactDescr : TCLRArray; // Bar description, inactive positions colors (if reversed gradient); + fBarKind : TQBarKind; // flat or rounded + fBarLook : TQBarLook; // blMetal or blGlass + fOrientation : TQBarOrientation; // horizontal or vertical + fInternalBorder, // space between the shape and the bar itself (1 or two pixels) + fUSefullDrawSpace, // size of the bar minus border + fBorderSize : Integer; // 2*(border+shape) + fHasShape : Boolean; // the surrounding line + fShapeClr : TColor; // above' color + fCorner : Integer; // shape' corner + fStartClr, // left (or bottom) color + fFinalClr, // right (or top) color + fBkgClr : TColor; // background color. + fMonoClr : Boolean; // True if StartColor = FinalColor. + fInvInactPos, // If true, and gradient, -> inverted; + fShowInactPos : Boolean; // Bars corresp. to positions above actual are drawn in fInactPosClr + fInactPosClr : TColor; // Above's color + fUSerPosPct : Real; // same as below, as percent, for displays + fUserPos, // value sent by user + fPosition, // above, normalized to width or height, and max; + fMinVisPos, // Minimum position to send to Paint(), to see at least one bar + fMaxPos : Integer; // max position as sent by user. + fByBlock, // if true, alternates colored and not colored pixels + fFullBlock : Boolean; // if true, blocks are drawn only when their max position is reached; + fSpaceSize, // space between two blocks + fBlockSize : Integer; // width (or height) of a block + fHideOnTerm : Boolean; // Hides the bar a tenth of a second after the painting of the last pixel row/column; + fCapAlign : TTextAlign; // left - right - centered + fCapPos : TPoint; // Internal - caption's top and left, based on canvas' current font + fHasCaption : Boolean; // Internal + fShowPosAsPct : Boolean; // If True, Hint and/or caption will show the value as a percent of the maximum. + fCaptionOvr : Boolean; // id. below; + fHintOvr : Boolean; // if True, each position changes => Hint <- fUserPos or fUSerPosPct dep. on ShowPosAsPct True/false; + fOnProgChange : TOnQProgressBar; // ProgressBar changing event + destructor Destroy; virtual; + end; + +// ---------------------------------------------------------- + TQProgressBar = object( TControl ) + {* This object implements all functionality of component. + + |TKOLQProgressBar is similar to a standard progress bar control and tries to emulate many of its features: + |

  • Has the same properties. Obviously you can use Progress, MaxProgress and Caption derived from + PControl with some specific caused by the component. Here its short description: + |

    • Progress is the position to be drawn on the bar. This should be the only thing changing, once setup is complete;

      • + |

    • MaxProgress is the maximum value you may send to the bar. It will be used to normalize positions sent compared to + |the size of the bar's drawspace;

      • + |

    • Caption - the control may display a basic caption. This caption's appearance depends on the bar canvas' font property. + It is neither XOR'ed nor anything like that: authors couldn't succeed at it. Moreover, despite a caption appears correctly within + horizontal bars, it certainly will give poor results within vertical bars as long as the caption stays horizontal. + |

    • + |

  • Can handle progress bar control's specific messages. You can send messages to control or receive from it (see the MSDN documentation for details) thus it behaves as an usual progress bar control: + |

    • PBM_GETPOS retrieves the current position of the progress bar;

      • + |

    • PBM_SETPOS sets the current position for a progress bar and redraws the bar to reflect the new position;

      • + |

    • PBM_GETRANGE retrieves information about the current high and low limits of a given progress bar control;

      • + |

    • PBM_SETRANGE sets the maximum value for a progress bar and redraws the bar to reflect the new range;

      • + |

    • PBM_SETRANGE32 Sets the range of a progress bar control to a 32-bit value.

+ + |
Use NewQProgressBar constuction function for creation of object instance. Here is the prototype: + ! function NewQProgressBar( AParent: PControl ): PQProgressBar; } + + protected + + procedure Paint; + procedure Resize; + procedure SetUsefullWidth; + procedure InitBlockArray; + procedure InitPixArray; + function MakeCylinder( h: Real ): Extended; + function GetGradientAr2( aColor: TColor; sz: Integer ): TClrArray; + function HLStoRGB( hue, lum, sat: THLSRange ): TColor; + function RGBtoHLS( RGBColor: TColor): THLSRec; + function GetColorBetween( AStartColor, AEndColor: TColor; PointValue, Von, Bis : Extended ): TColor; + function GetOrientation: TQBarOrientation; + procedure SetOrientation( Value: TQBarOrientation ); + function GetBarKind: TQBarKind; + procedure SetBarKind ( Value: TQBarKind ); + function GetBarLook: TQBarLook; + procedure SetBarLook ( Value: TQBarLook ); + procedure SetFCorner ( IsRounded: Boolean ); + function GetBoolCorner: Boolean; + function GetBkgColor: TColor; + procedure SetBkgColor ( aColor: TColor ); + function GetShape: Boolean; + procedure SetShape ( Value: Boolean ); + function GetShapeColor: TColor; + procedure SetShapeColor ( Value: TColor ); + function GetBlockSize: Integer; + procedure SetBlockSize ( Value: Integer ); + function GetSpaceSize: Integer; + procedure SetSpaceSize ( Value: Integer ); + function GetFullBlock: Boolean; + procedure SetFullBlock ( Value: Boolean ); + function GetMaxPos: Integer; + procedure SetMaxPos ( Value: Integer ); + function GetHideOnTerm: Boolean; + procedure SetHideOnTerm ( Value: Boolean); + function GetPosition: Integer; + procedure SetPosition ( Value: Integer ); + function GetStartClr: TColor; + procedure SetStartClr ( Value: TColor ); + function GetFinalClr: TColor; + procedure SetFinalClr ( Value: TColor ); + procedure SetBothColors ( Value: TColor ); + function GetInactivePos: Boolean; + procedure SetInactivePos( Value: Boolean ); + function GetInactPosClr: TColor; + procedure SetInactPosClr( Value: TColor ); + function GetInvInactPos: Boolean; + procedure SetInvInactPos( Value: Boolean ); + procedure SetCaption ( Value: string ); + function GetCapAlign: TTextAlign; + procedure SetCapAlign ( Value: TTextAlign ); + function GetCaptionOvr: Boolean; + procedure SetCaptionOvr ( Value: Boolean ); + function GetHintOvr: Boolean; + procedure SetHintOvr ( Value: Boolean ); + function GetShowPosAsPct: Boolean; + procedure SetShowPosAsPct( Value: Boolean ); + function GetOnProgressChange: TOnQProgressBar; + procedure SetOnProgressChange( const Value: TOnQProgressBar ); + + public + property Orientation : TQBarOrientation read GetOrientation write SetOrientation; + {* |It's the control orientation parameters at the parent, i.e. if you assign it to boVertical + then the control's progress will grow up from below upwards instead of from left corner to right. + |By default: boHorizontal. } + + property BarKind : TQBarKind read GetBarKind write SetBarKind; + {* Parameter that defines how the control's progress bar row will appear. + |By default: bkFlat. } + + property BarLook : TQBarLook read GetBarLook write SetBarLook; + {* Parameter that defines how the control's bar will look. + |blMetal takes the original color luminence into account when computing each pixel; + |blGlass don't. blGlass only works on the 'basic color' part of the color of each pixel. + |By default: blMetal. } + + property RoundCorner : Boolean read GetBoolCorner write SetFCorner; + {* |If True, the bar's external shape will appear with smoothly rounded corners, + otherwise it will be a rectangle. + |By default: True. } + + property BackgroundColor : TColor read GetBkgColor write SetBkgColor; + {* Parameter that defines control background color. + |By default: clWhite. } + + property BarColor : TColor read GetStartClr write SetBothColors; + {* Parameter that allows to define a single color bar in one shot: using + ! aPBar.BarColor:= clLime; + is equivalent to : + ! aPBar.StartColor := clLime; + ! aPBar.FinalColor := clLime; } + + property StartColor : TColor read GetStartClr write SetStartClr; + {* Left color of a two-colors horizontal bar, or bottom color for vertical bars. + |By default: clLime. } + + property FinalColor : TColor read GetFinalClr write SetFinalClr; + {* Right color of a two-colors horizontal bar, or Top color for vertical bars. + |By default: clLime (default bar is thus monocolor). } + + property ShowInactivePos : Boolean read GetInactivePos write SetInactivePos; + {* Inactive position are the positions not yet reached. + |If True, they'll be drawn in the + InactivePosColor, + |if False, only the background appears there. Inactive positions share appearance + properties and behaviour (like : by blocks or not, full blocks, BarKind, aso.) with active positions. + |Only the color differs. By default: False. } + + property InvertInactPos : Boolean read GetInvInactPos write SetInvInactPos; + {* |If True, the luminance of inactive positions color array is inverted. + Notice that the result is most often really dark. There's still some work to do there. + |Applies only on bkCylinder bars. By default: False. } + + property InactivePosColor: TColor read GetInactPosClr write SetInactPosClr; + {* Base color of inactive positions. + |By default: clGray. } + + property Shaped : Boolean read GetShape write SetShape; + {* Decides whether the bar has a surrounding line or not. + |By default: True. } + + property ShapeColor : TColor read GetShapeColor write SetShapeColor; + {* The color of that surrounding line. + |By default: RGB (0, 60, 116) (Dark blue) } + + property BlockSize : Integer read GetBlockSize write SetBlockSize; + {* TKOLQProgressBars can appear under the form of a continuous area or like "blocks" + separated by not-drawn spaces (where the background appears). + BlockSize defines the size of blocks in pixels. BlockSize and SpaceSize are ignored if + one of them is set to zero or set to a value greater than the internal available draw space. + |By default: 0. } + + property SpaceSize : Integer read GetSpaceSize write SetSpaceSize; + {* TKOLQProgressBars can appear under the form of a continuous area or like "blocks" + separated by not-drawn spaces (where the background appears). + SpaceSize defines the size of none drawn parts between two blocks in pixels. BlockSize and + SpaceSize are ignored if one of them is set to zero or set to a value greater than the internal + |available draw space. By default: 0. } + + property ShowFullBlock : Boolean read GetFullBlock write SetFullBlock; + {* If both BlockSize and SpaceSize have been defined, the bar will show an alternance + of blocks and spaces. In this case, if ShowFullBlock is set + |to True, each new block is drawn only when the position sent corresponds to + |the end of a block. If set to False, blocks are filled little by little. + |By default: False. } + + property HideOnTerminate : Boolean read GetHideOnTerm write SetHideOnTerm default False; + {* |If True, the bar will hide itself after it will receive a progress position + |equal to MaxProgress. In such a case, it will be up to you to show it again if you use it again: + !uses Windows, Messages, KOL, ..., KOLQProgBar; + ! //... + !var aPBar : PQProgressBar; + ! //... + !aPBar := NewQProgressBar( AParentForm ); + !aPBar.HideOnTerminate:= true; + !aPBar. ... + !// ... do something + !// ... our jobs finished and progress bar is hidden now + !// ... restore it with Progress:= 0 + !aPBar.Progress:= 0; + !aPBar.Show; + + |By default: False. } + + property CaptionAlign : TTextAlign read GetCapAlign write SetCapAlign; + {* Vertical alignment is always almost centered, this one is horizontal alignment, + |and can be taLeft, taCenter, taRight. + |By default: taLeft. } + + property AutoCaption : Boolean read GetCaptionOvr write SetCaptionOvr; + {* |Both caption and hint can be set to display automatically the value Progress. + |If True, Hint value is refreshed each time you send a new position and Caption + value is updated within the paint method. + |By default: False. } + + property AutoHint : Boolean read GetHintOvr write SetHintOvr; + {* |Both caption and hint can be set to display automatically the value Progress. + |If True, Hint value is refreshed each time you send a new position and Caption + value is updated within the paint method. For hint to show when your user moves it's mouse over your bar, + |you must add USE_MHTOOLTIP conditional symbol into the project options list and your KOLProject + |must have the ShowHint property set to True. By default: False. } + + property ShowPosAsPct : Boolean read GetShowPosAsPct write SetShowPosAsPct; + {* |If True, both Hint and Caption will show the last received position as + |a percentage of MaxProgress, followed by the string ' %'. + |By default: False. } + + property OnProgressChange: TOnQProgressBar read GetOnProgressChange write SetOnProgressChange; + {* | Called when Progress value is changed. } + + end; + +// ---------------------------------------------------------- +const + // NIH... Out a Microsoft knowledge base article, see below "RGBtoHLS" and "HLStoRGB" + HLSMAX = High(THLSRange); // H,L, and S vary over 0-HLSMAX + RGBMAX = 255; // R,G, and B vary over 0-RGBMAX + // HLSMAX BEST IF DIVISIBLE BY 6 + // RGBMAX, HLSMAX must each fit in a byte. + // Hue is undefined if Saturation is 0 (grey-scale) + // This value determines where the Hue scrollbar is + // initially set for achromatic colors + UNDEFINED = HLSMAX * 2 div 3; + +// ---------------------------------------------------------- +function NewQProgressBar( AParent: PControl ): PQProgressBar; +// ---------------------------------------------------------- + +implementation + +// ---------------------------------------------------------- +function QProgBar_WndProc( Control: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +var + PaintStruct: TPaintStruct; + ProgressBar: PQProgressBar; +begin + Result := False; + ProgressBar:= PQProgressBar( Control ); + case ( Msg.message ) of + WM_PAINT: + begin + BeginPaint( ProgressBar.Handle, PaintStruct ); + ProgressBar.Paint; + //Result:= True; + //Rslt:= 0; + EndPaint( ProgressBar.Handle, PaintStruct ); + end; + WM_SIZE: + ProgressBar.Resize; + PBM_GETPOS: + begin + Rslt:= ProgressBar.GetPosition; + Result:= true; + end; + PBM_SETPOS: + begin + Rslt:= ProgressBar.GetPosition; + if ( Msg.wParam > 0 ) then + ProgressBar.SetPosition( Msg.wParam ) + else + ProgressBar.SetPosition( 0 ); + with PQDataObj( ProgressBar.CustomObj )^ do + if Assigned( fOnProgChange ) then + fOnProgChange( ProgressBar ); + Result := true; + end; + PBM_GETRANGE: + begin + if ( Msg.wParam ) > 0 then + Rslt:= 0 + else + Rslt:= ProgressBar.GetMaxPos; + Result:= true; + end; + PBM_SETRANGE: + begin + ProgressBar.SetMaxPos( Hi(Msg.lParam) ); + Result:= true; + end; + PBM_SETRANGE32: + begin + ProgressBar.SetMaxPos( Msg.lParam ); + Result:= true; + end; + end; // case +end; + +// ---------------------------------------------------------- +function NewQProgressBar( AParent: PControl ): PQProgressBar; +var + Data: PQDataObj; +begin + Result := PQProgressBar( _NewControl( AParent, 'QProgressBar', + WS_VISIBLE + WS_CHILD + SS_NOTIFY, False, @LabelActions ) ); + + New( Data, Create ); // releases authomatically when the object destroys + Result.CustomObj := Data; + + with Data^ do + begin + SetLength( fPosDescr, 1 ); + fPosDescr[0].isInBlock := False; + fByBlock := False; + fFullBlock := False; + fBlockSize := 0; + fSpaceSize := 0; + fOrientation := boHorizontal; + fBarKind := bkFlat; + fBarLook := blMetal; + fPosition := 0; + fHasShape := True; + fShapeClr := RGB (0, 60, 116); + fStartClr := clLime; + fFinalClr := clLime; + fMonoClr := True; + fBkgClr := clWhite; + fShowInactPos := False; + fInactPosClr := clGray; + fInvInactPos := False; + fMaxPos := 100; + fInternalBorder:= 2; + fBorderSize := 4; + with Result^ do + begin + SetUsefullWidth; + InitPixArray; + end; + fCorner := 5; + fCapPos.X := 0; + fCapPos.Y := 0; + fHasCaption := False; + fCaptionOvr := False; + fHintOvr := False; + fShowPosAsPct := False; + fUserPos:= 0; + end; + + with Result^ do + begin + TabStop:= False; + Caption:= ''; + Enabled:= True; + Width:= 200; + Height:= 20; + DoubleBuffered:= true; + end; + + Result.AttachProc( QProgBar_WndProc ); +end; + + +// ---------------------------------------------------------- +procedure TQProgressBar.InitBlockArray; +// fPosDescr[n] describes each possible position, storing : +// - wether it is in a block or not ; <- drawing blocks instead of a continuous line +// - what is the block limit for this position; <- (if full blocks only are to be drawn, then +// only those which limit is below(H) above(V) current position will be drawn.) +// Computed on size/resize and blocks/space sizes changes only, to avoid computations at runTime. +var i, + blkStart, + blkStop : Integer; + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + if ( D.fBlockSize = 0 ) or ( D.fSpaceSize = 0 ) then Exit; + + if ( D.fUSefullDrawSpace <= 0 ) then + SetLength( D.fPosDescr, 1 ) // Position 0 is always False + else SetLength( D.fPosDescr, D.fUSefullDrawSpace + 1 ); + + case ( D.fOrientation ) of + boHorizontal : + begin + D.fPosDescr[0].isInBlock := False; + blkStart := 3; + blkStop := blkStart + D.fBlockSize -1 ; + with D^ do + for i := 1 to High( fPosDescr ) do + begin + fPosDescr[i].isInBlock := (i >= blkStart) and (i <= blkStop); + fPosDescr[i].blkLimit := blkStop; + if ( i = blkStop ) then + begin + blkStart := blkStop + fSpaceSize + 1; + blkStop := blkStart + fBlockSize - 1; + if blkStop > High( fPosDescr ) then blkStop := High( fPosDescr ); + end; + end; + end; {boHrz} + else // boVertical; "Else" avoids compiler warnings + begin + D.fPosDescr[High( D.fPosDescr )].isInBlock := False; + blkStart := High( D.fPosDescr ) - 3; + blkStop := blkStart - D.fBlockSize + 1 ; + with D^ do + for i := D.fUSefullDrawSpace downto D.fBorderSize do + begin + fPosDescr[i].isInBlock := (i <= blkStart) and (i >= blkStop); + fPosDescr[i].blkLimit := blkStop; + if ( i = blkStop ) then + begin + blkStart := blkStop - fSpaceSize - 1; + blkStop := blkStart - fBlockSize + 1; + if ( blkStop < fBorderSize ) then blkStop := fBorderSize; + end; + end; + end; {boVert} + end; {case} +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.InitPixArray; +// Compute and stores each pixel color, in the case of a gradient, or a double +// gradient (both directions) in order to speed up things at run time. +var i, j, + rowSz : integer; + clr : TColor; + HLSr : THLSRec; + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + + with D^ do + case ( fOrientation ) of + boHorizontal : rowSz := Height - (fBorderSize) + 1; + else rowSz := Width - (fBorderSize) + 1; // boVertical; + end; {Case} + + with D^ do + if ( fUSefullDrawSpace <= 0 ) then + SetLength( fPixDescr, 1) // Position 0 is allways False + else SetLength( fPixDescr, fUSefullDrawSpace + 1); + + // Populates active positions colors array ; + // -> GetColorBetween works on the horizontal gradient, in the case of a + // boHorizontal bar, with two colors (or on the vertical one, if the + // bar is vertical). + // -> GetGradientAr2 then returns the row gradient, based upon the header + // pixel value for that row in order to give the cylinder appearance. + + with D^ do + for i := 0 to fUSefullDrawSpace do + begin + clr := GetColorBetween( fStartClr, fFinalClr, (i), 0, fUSefullDrawSpace ); + if ( fBarKind = bkCylinder ) then + fPixDescr[i] := GetGradientAr2( clr, rowSz ) + else + for j := 0 to rowSz -1 do + begin + SetLength( fPixDescr[i], rowSz); + fPixDescr[i, j] := clr; + end; + end; + + // inactive positions decription, used in case 'showInactive positions' is true; + with D^ do + if ( ( Height - fBorderSize ) <= 0 ) then + begin + SetLength( fInactDescr, 1 ); + fInactDescr[0] := fInactPosClr; + end + else + begin + if ( fBarKind = bkCylinder ) then + fInactDescr := GetGradientAr2( fInactPosClr, rowSz ) + else + begin + SetLength( fInactDescr,rowSz ); + for j := 0 to rowSz - 1 do + fInactDescr[j] := fInactPosClr; + end; + end; + + // case cylindric bar : the background can be basically reversed. + with D^ do + if ( ( fBarKind = bkCylinder ) and ( fInvInactPos ) ) then + for i := 0 to rowSz - 1 do + begin + HLSr := RGBtoHLS( fInactDescr[i] ); + HLSr.lum := 240 - HLSr.lum; + fInactDescr[i] := HLStoRGB(HLSr.hue, HLSr.lum, HLSr.sat); + end; + +end; + +// ---------------------------------------------------------- +function TQProgressBar.MakeCylinder( h: real): Extended; // NIH +// (c) Matthieu Contensou (http://www25.brinkster.com/waypointfrance/cpulog/index.asp) +// who computed the polynome used to provide the "cylinder" appearence to bars : +// "f (h) = -4342,9 h^5 + 10543 h^4 - 8216 h^3 + 2018,1 h^2 + 11,096 h + 164,6" +// "h is the order of the wanted pixel in a column (horizontal bar), or in +// a row (vertical bar), with a value between 0 and 1 (0 -> 100%)" +begin + Result := ( (-4342.9 * ( IntPower(h, 5) ) ) + + ( 10543 * ( IntPower(h, 4) ) ) + - ( 8216 * ( IntPower(h, 3) ) ) + + ( 2018.1 * ( IntPower(h, 2) ) ) + + ( 11.096 * h ) + 164.6 ) ; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetGradientAr2( aColor: TColor; sz: Integer): TClrArray; +// Version corrected by Bernd Kirchhoff (http://home.germany.net/100-445474/) +// Returns an array of size sz, filled up with a basic gradient; Used to +// provide the "cylindric" appearance. +var i,RP: Integer; + HLSr: THLSRec; + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + SetLength( Result, sz ); + for i := 0 to sz - 1 do + begin + HLSr := RGBtoHLS(aColor); + // (c) Bernd Kirchhoff >>>-------------------------------------------------- + if ( D.fBarLook = blGlass ) then + HLSr.lum := Round( MakeCylinder( (i / sz)) ) + else + begin + rp:= HLSr.lum - 212; + rp:= rp + Trunc( MakeCylinder( i / sz) ); + if ( rp < 0 ) then rp:= 0; + if ( rp > 240 ) then rp:= 240; + HLSr.lum :=rp; + end; + // <<<----------------------------------------------------------------------- + Result[i] := HLStoRGB(HLSr.hue, HLSr.lum, HLSr.sat); + end; +end; + +// ---------------------------------------------------------- +function TQProgressBar.RGBtoHLS(RGBColor: TColor): THLSRec; // NIH +// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 +// This is the translation of a Microsoft knowledge base article, pubilshed +// under number Q29240. Msft's knowledge base has a lot of interesting articles. + +//(knowledge base = http://support.microsoft.com/default.aspx?scid=FH;EN-US;KBHOWTO) + +var + R, G, B: Integer; // input RGB values + H, L, S: Integer; + cMax, cMin: Byte; // max and min RGB values + Rdelta, Gdelta, Bdelta: Integer; // intermediate value: % of spread from max +begin + // get R, G, and B out of DWORD + R := GetRValue(RGBColor); + G := GetGValue(RGBColor); + B := GetBValue(RGBColor); + + // calculate lightness + cMax := max( max(R,G), B); + cMin := min( min(R,G), B); + L := ( ( (cMax+cMin) * HLSMAX) + RGBMAX ) div (2*RGBMAX); + + if (cMax = cMin) then // r=g=b --> achromatic case + begin + S := 0; // saturation + H := UNDEFINED; // hue + end else + begin // chromatic case + if (L <= (HLSMAX div 2) ) // saturation + then S := ( ( (cMax-cMin) * HLSMAX ) + ( (cMax+cMin) div 2) ) div (cMax+cMin) + else S := ( ( (cMax-cMin) * HLSMAX ) + ( (2*RGBMAX-cMax-cMin) div 2) ) div (2*RGBMAX-cMax-cMin); + // hue + Rdelta := ( ( (cMax-R) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); + Gdelta := ( ( (cMax-G) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); + Bdelta := ( ( (cMax-B) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); + + if R = cMax then H := Bdelta - Gdelta + else if G = cMax then H := (HLSMAX div 3) + Rdelta - Bdelta + else {B=cMax} H := ( (2*HLSMAX) div 3) + Gdelta - Rdelta; + if (H < 0) then H := H + HLSMAX; + if (H > HLSMAX) then H := H - HLSMAX; + end; + + Result.Hue := H; + Result.Lum := L; + Result.Sat := S; +end; + +// ---------------------------------------------------------- +function TQProgressBar.HLStoRGB( hue, lum, sat: THLSRange): TColor; // NIH +// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 +var + R,G,B : Integer; // RGB component values + Magic1,Magic2: Integer; // calculated magic numbers (really!) + + + { ----------------- LOCAL -----------------} + + function HueToRGB(n1, n2, hue: Integer): Integer; // (c) Microsoft. + // utility routine for HLStoRGB + begin + // range check: note values passed add/subtract thirds of range + if hue < 0 then Inc(hue, HLSMAX) + else if hue > HLSMAX then Dec(hue, HLSMAX); + + (* return r,g, or b value from this tridrant *) + if ( hue < (HLSMAX div 6) ) + then result := ( n1 + ( ( (n2-n1) * hue + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) + else if hue < (HLSMAX div 2) + then result := n2 + else if hue < ( (HLSMAX*2) div 3 ) + then result := ( n1 + ( ( (n2-n1) * ( ( (HLSMAX*2) div 3 ) - hue ) + + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) + else result := n1; + end; {HueToRGB} + + { ----------------- \LOCAL\ -----------------} + +begin + if ( Sat = 0 ) then // achromatic case + begin + R := (Lum*RGBMAX) div HLSMAX; + G := R; + B := R; + if not( Hue = UNDEFINED ) then + begin + // ...trap impossible conversions (?)... + end; + end else + begin // chromatic case + if (Lum <= (HLSMAX div 2)) // set up magic numbers + then Magic2 := ( Lum * ( HLSMAX + Sat ) + ( HLSMAX div 2 ) ) div HLSMAX + else Magic2 := Lum + Sat - ( (Lum * Sat) + ( HLSMAX div 2 ) ) div HLSMAX; + Magic1 := 2*Lum - Magic2; + + // get RGB, change units from HLSMAX to RGBMAX + R := ( HueToRGB( Magic1, Magic2, Hue + ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; + G := ( HueToRGB( Magic1, Magic2, Hue )* RGBMAX +(HLSMAX div 2 ) ) div HLSMAX; + B := ( HueToRGB( Magic1, Magic2, Hue - ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; + end; + Result := RGB(R ,G, B); +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetColorBetween( AStartColor, AEndColor: TColor; PointValue, + Von, Bis : Extended ): TColor; // NIH +// Found on efg's colors pages, at http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/Color.htm +// "Color gradient" row, cworn's UseNet Post. +// Author is unknown, but remains holder for intellectual property. +// High speed function which returns the gradient color value for a pixel depending +// on start and final color, size of the gradient area , and the place of the current pixel; + +var + F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte; + + { ----------------- LOCAL -----------------} + function CalcColorBytes(fb1, fb2: Byte): Byte; + begin + Result := fb1; + if ( fb1 < fb2 ) then Result := FB1 + Trunc( F * (fb2 - fb1) ); + if ( fb1 > fb2 ) then Result := FB1 - Trunc( F * (fb1 - fb2) ); + end; + { ----------------- \LOCAL\ -----------------} + +begin + if ( PQDataObj( CustomObj ).fMonoClr ) or ( PointValue <= Von ) then + begin + Result := AStartColor; + Exit; + end; + if ( PointValue >= Bis ) then + begin + Result := AEndColor; + Exit; + end; + F := (PointValue - Von) / (Bis - Von); + asm + mov EAX, AStartColor + cmp EAX, AEndColor + je @@exit + mov r1, AL + shr EAX,8 + mov g1, AL + shr Eax,8 + mov b1, AL + mov Eax, AEndColor + mov r2, AL + shr EAX,8 + mov g2, AL + shr EAX,8 + mov b2, AL + push ebp + mov al, r1 + mov dl, r2 + call CalcColorBytes + pop ecx + push ebp + Mov r3, al + mov dL, g2 + mov al, g1 + call CalcColorBytes + pop ecx + push ebp + mov g3, Al + mov dL, B2 + mov Al, B1 + call CalcColorBytes + pop ecx + mov b3, al + XOR EAX,EAX + mov AL, B3 + SHL EAX,8 + mov AL, G3 + SHL EAX,8 + mov AL, R3 +@@Exit: + mov @result, eax + end; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.Paint; +// Main loop. Called each time a setting changes, notably, each time +// a new position is sent. +// Surround is drawn first, then the bar itself. Caption is added lastly (if needed). + +var i,k,sp: Integer; + OldBkMode : Integer; + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + + with Canvas^ do + begin + Brush.Color:= Parent.Color; + FillRect( MakeRect(0, 0, Width, Height )); + + // -1- Bevel + if ( D.fHasShape ) then + begin + Pen.PenWidth := 1; + Brush.BrushStyle := bsSolid; + Brush.Color:= Parent.Color; + FillRect( MakeRect(0, 0, Width, Height )); + Brush.Color := D.fBkgClr; + Pen.Color := D.fShapeClr; + RoundRect (0, 0, Width, Height, D.fCorner, D.fCorner); + end; + end; + + // -2- The bar itself + case D.fOrientation of + boHorizontal : + begin + for i := ( D.fBorderSize - 1 ) to D.fPosition do + begin + if ( D.fByBlock ) then + begin + if ( D.fPosDescr[i].isInBlock = true) then + begin + if ( (D.fFullBlock) and (D.fPosition >= D.fPosDescr[i].blkLimit) ) + or not( D.fFullBlock ) then + for k := (D.fBorderSize - 1) to (Height - (D.fBorderSize)) + do Canvas.Pixels [i,k] := D.fPixDescr[i,k] + else if (D.fShowInactPos) then + for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) + do Canvas.Pixels [i,k] := D.fInactDescr[k]; + end; + end else + begin + for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) do + Canvas.Pixels [i,k] := D.fPixDescr[i,k]; + end; + end; + // Now dealing with inactive positions, if they're to be drawn. + if ( D.fShowInactPos ) then + begin + if (D.fPosition < 3) then sp := 3 + else sp := D.fPosition + 1; + for i := sp to D.fUSefullDrawSpace do + begin + if (D.fByBlock) then + begin + if (D.fPosDescr[i].isInBlock = True) then + begin + for k := (D.fBorderSize -1) to (Height -(D.fBorderSize)) do + Canvas.Pixels [i,k] := D.fInactDescr[k]; + end; + end else //If not(byBlock), all pixels must be drawn + begin + for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) do + Canvas.Pixels [i,k] := D.fInactDescr[k]; + end; + end; {for} + end; {inactive} + end; {boHorizontal} + boVertical : + begin + for i := (D.fUSefullDrawSpace-1) downto Height - D.fPosition do + begin + if (D.fByBlock) then + begin + if (D.fPosDescr[i].isInBlock = true) then + begin + if ( (D.fFullBlock) and ((Height - D.fPosition) <= D.fPosDescr[i].blkLimit) ) + or not( D.fFullBlock ) then + for k := (D.fBorderSize - 1 ) to (Width - (D.fBorderSize)) + do Canvas.Pixels [k,i] := D.fPixDescr[i,k] + else if ( D.fShowInactPos ) then + for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) + do Canvas.Pixels [k,i] := D.fInactDescr[k]; + end; + end + else + for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) + do Canvas.Pixels [k,i] := D.fPixDescr[i,k]; + end; + // inactive positions : + if (D.fShowInactPos) then + begin + if ( D.fPosition < 3 ) then sp := D.fUSefullDrawSpace + else sp := Height - D.fPosition - 1; + for i := sp downto D.fBorderSize do + begin + if ( D.fByBlock ) then + begin + if ( D.fPosDescr[i].isInBlock = true ) then + begin + for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) do + Canvas.Pixels [k,i] := D.fInactDescr[k]; + end; + end else + for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) + do Canvas.Pixels [k,i] := D.fInactDescr[k]; + end; {for... downto} + end; {inactive} + end; {boVertical} + end; // Case + + // caption management. The font is the canvas' one. Can be overrided + // using the Font property : + if ( D.fCaptionOvr ) then + begin + if ( D.fShowPosAsPct ) then SetCaption( Double2Str( D.fUSerPosPct ) + '%') + else SetCaption( Int2Str(D.fUSerPos) ); + end + else SetCaption( Caption ); + + if ( D.fHasCaption ) then + begin + OldBkMode := SetBkMode(Canvas.Handle, Windows.TRANSPARENT); + with Canvas^ do + begin + TextOut(D.fCapPos.X, D.fCapPos.Y, Caption); + end; + SetBkMode(Canvas.Handle, OldBkMode); + end; + +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.Resize; +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fBorderSize := D.fInternalBorder shl 1; + SetUsefullWidth; + + if ( D.fByBlock ) then InitBlockArray; + InitPixArray; + SetPosition( D.fUserPos ); // position is computed, then bar is invalidated ; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetUsefullWidth; +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + case ( D.fOrientation ) of + boHorizontal : D.fUSefullDrawSpace := ( Width - ( D.fBorderSize )); + boVertical : D.fUSefullDrawSpace := ( Height - ( D.fBorderSize )); + end; + D.fMinVisPos := D.fBorderSize + 1; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetFCorner( IsRounded:Boolean ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + if ( IsRounded ) then D.fCorner := 5 + else D.fCorner := 0; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetBoolCorner: Boolean; +begin + Result := ( PQDataObj( CustomObj ).fCorner > 0 ); +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetBarKind: TQBarKind; +begin + Result:= PQDataObj( CustomObj ).fBarKind; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetBarKind( Value: TQBarKind ); +begin + PQDataObj( CustomObj ).fBarKind := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetBarLook: TQBarLook; +begin + Result:= PQDataObj( CustomObj ).fBarLook; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetBarLook( Value: TQBarLook ); +begin + PQDataObj( CustomObj ).fBarLook := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetOrientation: TQBarOrientation; +begin + Result:= PQDataObj( CustomObj ).fOrientation; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetOrientation( Value: TQBarOrientation ); +var newH, + newW: Integer; + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + if ( Value <> D.fOrientation ) then + begin + if ( ( Value = boVertical) and ( Height < Width) ) + or ( ( Value = boHorizontal) and ( Width < Height) ) + then + begin + newW := Height; + newH := Width; + Height := newH; + Width := newW; + end; + D.fOrientation := Value; + end; + case ( Value ) of + boHorizontal : if Height < 10 + then D.fInternalBorder := 1 + else D.fInternalBorder := 2; + boVertical : if Width < 10 + then D.fInternalBorder := 1 + else D.fInternalBorder := 2; + end; //Case + D.fBorderSize := D.fInternalBorder shl 1; + SetUsefullWidth; + InitBlockArray; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetBkgColor: TColor; +begin + Result:= PQDataObj( CustomObj ).fBkgClr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetBkgColor( aColor: TColor ); +begin + PQDataObj( CustomObj ).fBkgClr := aColor; + Invalidate; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetShape( Value: Boolean ); +begin + PQDataObj( CustomObj ).fHasShape := Value; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetShape: Boolean; +begin + Result:= PQDataObj( CustomObj ).fHasShape; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetShapeColor( Value: TColor ); +begin + PQDataObj( CustomObj ).fShapeClr := Value; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetShapeColor: TColor; +begin + Result:= PQDataObj( CustomObj ).fShapeClr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetBlockSize( Value:Integer ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + case D.fOrientation of + boHorizontal : if ( Value > Width - ( D.fInternalBorder shl 1 ) ) then Exit; + boVertical : if ( Value > Height - ( D.fInternalBorder shl 1) ) then Exit; + end; {case} + + D.fBlockSize := Abs(value); + D.fByBlock := (D.fBlockSize > 0) and (D.fSpaceSize > 0); + if ( D.fByBlock ) then InitBlockArray; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetBlockSize: Integer; +begin + Result:= PQDataObj( CustomObj ).fBlockSize; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetSpaceSize( Value: Integer); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + case D.fOrientation of + boHorizontal : if ( Value > Width - (D.fInternalBorder SHL 1) ) then Exit; + boVertical : if ( Value > Height - (D.fInternalBorder SHL 1) ) then Exit; + end; {case} + + D.fSpaceSize := Abs(value); + D.fByBlock := ( D.fBlockSize > 0 ) and ( D.fSpaceSize > 0 ); + if ( D.fByBlock ) then InitBlockArray; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetSpaceSize: Integer; +begin + Result:= PQDataObj( CustomObj ).fSpaceSize; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetFullBlock( Value:Boolean ); +begin + PQDataObj( CustomObj ).fFullBlock := Value; + if ( Value ) then InitBlockArray; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetFullBlock: Boolean; +begin + Result:= PQDataObj( CustomObj ).fFullBlock; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetMaxPos( Value: Integer ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + if ( Value < 0 ) then D.fMaxPos := 0 + else D.fMaxPos := Value; + SetPosition( D.fUserPos ); +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetMaxPos: Integer; +begin + Result:= PQDataObj( CustomObj ).fMaxPos; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetPosition( Value: Integer ); +var + tmpfPos : Real; D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fUserPos := Value; + if ( D.fMaxPos = 0 ) then Exit; + try + if ( Value <= 0 ) then + begin + D.fPosition := 0; + Exit; + end + else if ( Value > D.fMaxPos ) then Value := D.fMaxPos; + + D.fUSerPosPct := (100 * Value) / D.fMaxPos; + tmpfPos := D.fUsefullDrawSpace * D.fUSerPosPct / 100; + // If value( user position) > 0, make sure that at least one bar is visible + if ( tmpfPos > 0.00 ) and ( tmpfPos < D.fMinVisPos ) + then D.fPosition := D.fMinVisPos + else if tmpfPos > D.fUsefullDrawSpace + then D.fPosition := D.fUsefullDrawSpace + else D.fPosition := Round( tmpfPos ); + // Hint is managed here (whereas caption, which ahs to be painted, + // is managed in the paint() proc). + {$IFDEF USE_MHTOOLTIP} + if ( D.fHintOvr ) then + if ( D.fShowPosAsPct ) then Hint.Text := Double2Str( D.fUSerPosPct ) + ' %' + else Hint.Text := Int2Str( D.fUSerPos ); + {$ENDIF} + finally + Invalidate; + if ( ( D.fHideOnTerm ) and ( Value = D.fMaxPos ) ) then + begin + Sleep(100); + Hide; + end; + end; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetPosition: Integer; +begin + Result:= PQDataObj( CustomObj ).fUserPos; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetStartClr( Value: TColor); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fStartClr := Value; + D.fMonoClr := ( D.fStartClr = D.fFinalClr ); + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetStartClr: TColor; +begin + Result:= PQDataObj( CustomObj ).fStartClr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetFinalClr( Value: TColor ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fFinalClr := Value; + D.fMonoClr := ( D.fStartClr = D.fFinalClr ); + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetFinalClr: TColor; +begin + Result:= PQDataObj( CustomObj ).fFinalClr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetBothColors( Value: TColor ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fMonoClr := True; + D.fStartClr := Value; + D.fFinalClr := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetInactivePos: Boolean; +begin + Result:= PQDataObj( CustomObj ).fShowInactPos; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetInactivePos( Value: Boolean ); +begin + PQDataObj( CustomObj ).fShowInactPos := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetInactPosClr: TColor; +begin + Result:= PQDataObj( CustomObj ).fInactPosClr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetInactPosClr( Value: TColor ); +begin + PQDataObj( CustomObj ).fInactPosClr := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetHideOnTerm( Value: Boolean ); +begin + PQDataObj( CustomObj ).fHideOnTerm:= Value; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetHideOnTerm: Boolean; +begin + Result:= PQDataObj( CustomObj ).fHideOnTerm; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetInvInactPos: Boolean; +begin + Result:= PQDataObj( CustomObj ).fInvInactPos; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetInvInactPos( Value: Boolean); +// invert Inactive Positions lum. +begin + PQDataObj( CustomObj ).fInvInactPos := Value; + InitPixArray; + Invalidate; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetCaption( Value: string ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + Caption := Value; + D.fHasCaption := not( Value = '' ); + + if ( D.fHasCaption ) then + begin + //-1- Centering vertically + D.fCapPos.Y := ( Height - Canvas.textHeight( 'Pg' ) ) div 2 ; + case ( D.fCapAlign ) of + taLeft: + begin + D.fCapPos.X := 0; + end; + taCenter: + begin + D.fCapPos.X := ( Width - Canvas.textWidth( Value ) ) div 2; + end; + else begin //right alignment; -taRight- + D.fCapPos.X := ( Width - Canvas.textWidth( value ) ) -1 ; + end; + end; {case} + end; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetCapAlign: TTextAlign; +begin + Result:= PQDataObj( CustomObj ).fCapAlign; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetCapAlign( Value: TTextAlign ); +var + D: PQDataObj; +begin + D:= PQDataObj( CustomObj ); + D.fCapAlign := Value; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetCaptionOvr: Boolean; +begin + Result:= PQDataObj( CustomObj ).fCaptionOvr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetCaptionOvr( Value:Boolean ); +begin + PQDataObj( CustomObj ).fCaptionOvr := Value; + Invalidate; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetHintOvr: Boolean; +begin + Result:= PQDataObj( CustomObj ).fHintOvr; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetHintOvr( Value: Boolean ); +begin + PQDataObj( CustomObj ).fHintOvr:= Value; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetShowPosAsPct( Value: Boolean ); +begin + PQDataObj( CustomObj ).fShowPosAsPct:= Value; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetShowPosAsPct: Boolean; +begin + Result:= PQDataObj( CustomObj ).fShowPosAsPct; +end; + +// ---------------------------------------------------------- +function TQProgressBar.GetOnProgressChange: TOnQProgressBar; +begin + Result:= PQDataObj( CustomObj ).fOnProgChange; +end; + +// ---------------------------------------------------------- +procedure TQProgressBar.SetOnProgressChange( const Value: TOnQProgressBar ); +begin + PQDataObj( CustomObj ).fOnProgChange:= Value; +end; + +// ---------------------------------------------------------- +destructor TQDataObj.Destroy; +begin + @fOnProgChange:= nil; + SetLength( fPosDescr, 0); + SetLength( fPixDescr, 0); + inherited; +end; + +// ---------------------------------------------------------- + + +end. + diff --git a/Addons/KOLRarBar.pas b/Addons/KOLRarBar.pas new file mode 100644 index 0000000..c690a5a --- /dev/null +++ b/Addons/KOLRarBar.pas @@ -0,0 +1,410 @@ +unit KOLRarBar; + +interface + +uses Windows, Messages, Kol, Objects; + +type + PRarBar = ^TRarBar; + TRarInfoBar = PRarBar; + TRarBar = object(TObj) + private + { Private declarations } + FControl: PControl; + FPosition: integer; + FShowPerc: boolean; + FFont: PGraphicTool; + + FLineColor,FTopColor,FSideColor1,FSideColor2,FEmptyColor1,FEmptyColor2, + FEmptyFrameColor1,FEmptyFrameColor2,FBottomFrameColor,FBottomColor, + FFilledFrameColor,FFilledColor,FFilledSideColor1,FFilledSideColor2: TColor; + + TopX,TopY,Size: integer; + + FMin,FMax: integer; + OldWind,NewWind: integer; + procedure SetPos(P: integer); + procedure SetMin(M: integer); + procedure SetMax(M: integer); + procedure SetFont(F: PGraphicTool); + + procedure SetLineColor(C: TColor); + procedure SetTopColor(C: TColor); + procedure SetSideColor1(C: TColor); + procedure SetSideColor2(C: TColor); + procedure SetEmptyColor1(C: TColor); + procedure SetEmptyColor2(C: TColor); + procedure SetEmptyFrameColor1(C: TColor); + procedure SetEmptyFrameColor2(C: TColor); + procedure SetBottomFrameColor(C: TColor); + procedure SetBottomColor(C: TColor); + procedure SetFilledFrameColor(C: TColor); + procedure SetFilledColor(C: TColor); + procedure SetFilledSideColor1(C: TColor); + procedure SetFilledSideColor2(C: TColor); + procedure SetShowPerc(V: boolean); + protected + { Protected declarations } + procedure NewWndProc(var Msg: TMessage); + procedure Paint; + public + destructor Destroy; virtual; + function SetPosition(X,Y: integer): PRarBar; overload; + function SetSize(X,Y: integer): PRarBar; overload; + function SetAlign(A: TControlAlign): PRarBar; overload; + { Public declarations } + property Position: integer read FPosition write SetPos; + property Max: integer read FMax write SetMax; + property Min: integer read FMin write SetMin; + property ShowPercent: boolean read FShowPerc write SetShowPerc; + property Font: PGraphicTool read FFont write SetFont; + + property LineColor: TColor read FLineColor write SetLineColor; + property TopColor: TColor read FTopColor write SetTopColor; + property SideColor1: TColor read FSideColor1 write SetSideColor1; + property SideColor2: TColor read FSideColor2 write SetSideColor2; + property EmptyColor1: TColor read FEmptyColor1 write SetEmptyColor1; + property EmptyColor2: TColor read FEmptyColor2 write SetEmptyColor2; + property EmptyFrameColor1: TColor read FEmptyFrameColor1 write SetEmptyFrameColor1; + property EmptyFrameColor2: TColor read FEmptyFrameColor2 write SetEmptyFrameColor2; + property BottomFrameColor: TColor read FBottomFrameColor write SetBottomFrameColor; + property BottomColor: TColor read FBottomColor write SetBottomColor; + property FilledFrameColor: TColor read FFilledFrameColor write SetFilledFrameColor; + property FilledColor: TColor read FFilledColor write SetFilledColor; + property FilledSideColor1: TColor read FFilledSideColor1 write SetFilledSideColor1; + property FilledSideColor2: TColor read FFilledSideColor2 write SetFilledSideColor2; + end; + +function NewTRarInfoBar(AOwner: PControl): PRarBar; + +implementation + +function NewTRarInfoBar; +var P: PRarBar; + C: PControl; +begin + C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil)); + C.CreateWindow; + New(P,Create); + AOwner.Add2AutoFree(P); + AOwner.Add2AutoFree(C); + P.FControl:=C; + P.FFont:=NewFont; + P.FFont.Color:=clPurple; + P.FFont.FontHeight:=-11; + P.FFont.FontName:=C.Font.FontName; + P.FFont.FontStyle:=[fsBold]; + P.FLineColor:=$FFE0E0; + P.FTopColor:=$FF8080; + P.FSideColor1:=$E06868; + P.FSideColor2:=$FF8080; + P.FEmptyFrameColor1:=$A06868; + P.FEmptyFrameColor2:=$BF8080; + P.FEmptyColor1:=$C06868; + P.FEmptyColor2:=$DF8080; + P.FBottomFrameColor:=$64408C; + P.FBottomColor:=$7A408C; + P.FFilledFrameColor:=$8060A0; + P.FFilledSideColor1:=$823C96; + P.FFilledSideColor2:=$8848C0; + P.FFilledColor:=$A060A0; + P.FShowPerc:=True; + P.FMin:=0; + P.FMax:=100; + P.FPosition:=0; + C.SetSize(70,180); + Result:=P; + P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC); + P.NewWind:=integer(MakeObjectInstance(P.NewWndProc)); + SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind); +end; + +destructor TRarBar.Destroy; +begin + SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind); + FreeObjectInstance(Pointer(NewWind)); + inherited; +end; + +function TRarBar.SetPosition(X,Y: integer): PRarBar; +begin + FControl.Left:=X; + FControl.Top:=Y; + Result:=@Self; +end; + +function TRarBar.SetSize(X,Y: integer): PRarBar; +begin + FControl.Width:=X; + FControl.Height:=Y; + Result:=@Self; +end; + +function TRarBar.SetAlign(A: TControlAlign): PRarBar; +begin + FControl.Align:=A; + Result:=@Self; +end; + +procedure TRarBar.NewWndProc; +begin + Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam); + case Msg.Msg of + WM_PAINT : Paint; + WM_SIZE : Paint; + WM_ACTIVATE: Paint; + end; +end; + +procedure TRarBar.SetFont(F: PGraphicTool); +begin + FFont.Assign(F); + Paint; +end; + +procedure TRarBar.SetMin; +begin + if M>FMax then M:=FMax; + FMin:=M; + Paint; +end; + +procedure TRarBar.SetMax; +begin + if MFMax then P:=FMax; + FPosition:=P; + Paint; +end; + +procedure TRarBar.SetLineColor; +begin + FLineColor:=C; + Paint; +end; + +procedure TRarBar.SetTopColor; +begin + FTopColor:=C; + Paint; +end; + +procedure TRarBar.SetSideColor1; +begin + FSideColor1:=C; + Paint; +end; + +procedure TRarBar.SetSideColor2; +begin + FSideColor2:=C; + Paint; +end; + +procedure TRarBar.SetEmptyColor1; +begin + FEmptyColor1:=C; + Paint; +end; + +procedure TRarBar.SetEmptyColor2; +begin + FEmptyColor2:=C; + Paint; +end; + +procedure TRarBar.SetEmptyFrameColor1; +begin + FEmptyFrameColor1:=C; + Paint; +end; + +procedure TRarBar.SetEmptyFrameColor2; +begin + FEmptyFrameColor2:=C; + Paint; +end; + +procedure TRarBar.SetBottomFrameColor; +begin + FBottomFrameColor:=C; + Paint; +end; + +procedure TRarBar.SetBottomColor; +begin + FBottomColor:=C; + Paint; +end; + +procedure TRarBar.SetFilledFrameColor; +begin + FFilledFrameColor:=C; + Paint; +end; + +procedure TRarBar.SetFilledColor; +begin + FFilledColor:=C; + Paint; +end; + +procedure TRarBar.SetFilledSideColor1; +begin + FFilledSideColor1:=C; + Paint; +end; + +procedure TRarBar.SetFilledSideColor2; +begin + FFilledSideColor2:=C; + Paint; +end; + +procedure TRarBar.SetShowPerc; +begin + FShowPerc:=V; + Paint; +end; + +procedure TRarBar.Paint; + procedure DrawFrame(C: PCanvas); + var PP: TPoint; + begin + C.Pen.Color:=FLineColor; + C.Pen.PenWidth:=1; + C.Pen.PenStyle:=psSolid; + C.Pen.PenMode:=pmCopy; + + C.MoveTo(TopX,TopY+5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X+15,PP.Y-5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X+15,PP.Y+5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X-15,PP.Y+5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X-15,PP.Y-5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X,PP.Y+(Size-10)); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X+15,PP.Y+5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X,PP.Y-(Size-10)); + GetCurrentPositionEx(C.Handle,@PP); + + C.MoveTo(PP.X,PP.Y+(Size-10)); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X+15,PP.Y-5); + GetCurrentPositionEx(C.Handle,@PP); + + C.LineTo(PP.X,PP.Y-(Size-10)); + end; + +var Points: array[1..4] of TPoint; + Prog,Perc: integer; + R: real; + S: string; + PP: TPoint; +begin + TopX:=0; + TopY:=5; + Size:=FControl.Height-TopY-5; + if (Size=0) or ((FMax-FMin)=0) then + begin + Perc:=0; + Prog:=0; + end + else + begin + R:=(FPosition-FMin)/((FMax-FMin)/(Size-10)); + Prog:=Round(R); + Perc:=Round(R/((Size-10)/100)); + end; + if Prog<0 then Prog:=0 else + if Prog>Size-10 then Prog:=Size-10; + FControl.Canvas.Brush.Color:=FControl.Color; + FControl.Canvas.FillRect(FControl.Canvas.ClipRect); + DrawFrame(FControl.Canvas); + FControl.Canvas.Brush.Color:=FTopColor; + FControl.Canvas.FloodFill(TopX+7,TopY+5,FControl.Canvas.Pixels[TopX+(15 div 2),TopY+5],fsSurface); + FControl.Canvas.Brush.Color:=FSideColor1; + FControl.Canvas.FloodFill(TopX+1,TopY+6,FControl.Canvas.Pixels[TopX+1,TopY+6],fsSurface); + FControl.Canvas.Brush.Color:=FSideColor2; + FControl.Canvas.FloodFill(TopX+29,TopY+6,FControl.Canvas.Pixels[TopX+29,TopY+6],fsSurface); + if Prog>0 then + begin + FControl.Canvas.MoveTo(TopX,TopY+Size-5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + FControl.Canvas.Pen.Color:=FBottomFrameColor; + + FControl.Canvas.LineTo(PP.X+15,PP.Y-5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + FControl.Canvas.LineTo(PP.X+15,PP.Y+5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + FControl.Canvas.Brush.Color:=FBottomColor; + FControl.Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface); + FControl.Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface); + FControl.Canvas.Brush.Color:=FFilledColor; + FControl.Canvas.Pen.Color:=FFilledFrameColor; + Points[1]:=MakePoint(TopX+15,TopY+Size-Prog); + Points[2]:=MakePoint(TopX,TopY+Size-Prog-5); + Points[3]:=MakePoint(TopX+15,TopY+Size-Prog-10); + Points[4]:=MakePoint(TopX+30,TopY+Size-Prog-5); + FControl.Canvas.Polygon(Points); + FControl.Canvas.Brush.Color:=FFilledSideColor1; + FControl.Canvas.FloodFill(TopX+1,TopY+Size-5-(Prog div 2),FSideColor1,fsSurface); + FControl.Canvas.Brush.Color:=FFilledSideColor2; + FControl.Canvas.FloodFill(TopX+29,TopY+Size-5-(Prog div 2),FSideColor2,fsSurface); + DrawFrame(FControl.Canvas); + end + else + begin + {EMPTY} + FControl.Canvas.MoveTo(TopX,TopY+Size-5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + FControl.Canvas.Pen.Color:=FEmptyFrameColor1; + + FControl.Canvas.LineTo(PP.X+15,PP.Y-5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + FControl.Canvas.Pen.Color:=FEmptyFrameColor2; + + FControl.Canvas.LineTo(PP.X+15,PP.Y+5); + GetCurrentPositionEx(FControl.Canvas.Handle,@PP); + + DrawFrame(FControl.Canvas); + FControl.Canvas.Brush.Color:=FEmptyColor1; + FControl.Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface); + FControl.Canvas.Brush.Color:=FEmptyColor2; + FControl.Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface); + end; + if FShowPerc then + begin + FControl.Canvas.Brush.Color:=FControl.Color; + FControl.Canvas.Font.Assign(FFont); + S:=Int2Str(Perc)+' %'; + FControl.Canvas.TextOut(TopX+33,TopY+Size-Prog-FControl.Canvas.TextHeight(S),S); + end; +end; + +end. + diff --git a/Addons/KOLRarProgBar.pas b/Addons/KOLRarProgBar.pas new file mode 100644 index 0000000..e0263a7 --- /dev/null +++ b/Addons/KOLRarProgBar.pas @@ -0,0 +1,377 @@ +////////////////////////////////////////////////////////////////////// +// // +// TRarProgressBar version 1.0 // +// Description: TRarProgressBar is a component which // +// displays dual progress bar like a WinRAR // +// Author: Dimaxx // +// // +////////////////////////////////////////////////////////////////////// + +unit KOLRarProgBar; + +interface + +uses Windows, Messages, Kol, Objects; + +type + PRarProgBar =^TRarProgBar; + TRarProgressBar = PRarProgBar; + TRarProgBar = object(TObj) + private + { Private declarations } + FControl: PControl; + FPosition1: integer; + FPosition2: integer; + FPercent1,FPercent2: integer; + FDouble: boolean; + B: PBitmap; + + FLightColor1,FDarkColor,FLightColor2,FFrameColor1,FFrameColor2, + FFillColor1,FFillColor2,FBackFrameColor1,FBackFrameColor2, + FBackFillColor,FShadowColor: TColor; + + TopX,TopY,SizeX,SizeY: integer; + + FMin,FMax: integer; + OldWind,NewWind: integer; + procedure SetPos1(P: integer); + procedure SetPos2(P: integer); + procedure SetMin(M: integer); + procedure SetMax(M: integer); + procedure SetDouble(D: boolean); + + procedure SetLightColor1(C: TColor); + procedure SetLightColor2(C: TColor); + procedure SetDarkColor(C: TColor); + procedure SetFrameColor1(C: TColor); + procedure SetFrameColor2(C: TColor); + procedure SetFillColor1(C: TColor); + procedure SetFillColor2(C: TColor); + procedure SetBackFrameColor1(C: TColor); + procedure SetBackFrameColor2(C: TColor); + procedure SetBackFillColor(C: TColor); + procedure SetShadowColor(C: TColor); + protected + { Protected declarations } + procedure NewWndProc(var Msg: TMessage); + procedure Paint; + public + destructor Destroy; virtual; + function SetPosition(X,Y: integer): PRarProgBar; overload; + function SetSize(X,Y: integer): PRarProgBar; overload; + function SetAlign(A: TControlAlign): PRarProgBar; overload; + { Public declarations } + property Position1: integer read FPosition1 write SetPos1; + property Position2: integer read FPosition2 write SetPos2; + property Percent1: integer read FPercent1; + property Percent2: integer read FPercent2; + property Max: integer read FMax write SetMax; + property Min: integer read FMin write SetMin; + property Double: boolean read FDouble write SetDouble; + + property LightColor1: TColor read FLightColor1 write SetLightColor1; + property LightColor2: TColor read FLightColor2 write SetLightColor2; + property DarkColor: TColor read FDarkColor write SetDarkColor; + property FrameColor1: TColor read FFrameColor1 write SetFrameColor1; + property FrameColor2: TColor read FFrameColor2 write SetFrameColor2; + property FillColor1: TColor read FFillColor1 write SetFillColor1; + property FillColor2: TColor read FFillColor2 write SetFillColor2; + property BackFrameColor1: TColor read FBackFrameColor1 write SetBackFrameColor1; + property BackFrameColor2: TColor read FBackFrameColor2 write SetBackFrameColor2; + property BackFillColor: TColor read FBackFillColor write SetBackFillColor; + property ShadowColor: TColor read FShadowColor write SetShadowColor; + + procedure Add1(D: integer); + procedure Add2(D: integer); + end; + +function NewTRarProgressBar(AOwner: PControl): PRarProgBar; + +implementation + +function Bounds(ALeft,ATop,AWidth,AHeight: integer): TRect; +begin + with Result do + begin + Left:=ALeft; + Top:=ATop; + Right:=ALeft+AWidth; + Bottom:=ATop+AHeight; + end; +end; + +function NewTRarProgressBar; +var P: PRarProgBar; + C: PControl; +begin + C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil)); + C.CreateWindow; + New(P,Create); + AOwner.Add2AutoFree(P); + AOwner.Add2AutoFree(C); + P.FControl:=C; + P.FMin:=0; + P.FMax:=100; + P.FPosition1:=0; + P.FPosition2:=0; + P.FDouble:=False; + P.FPercent1:=0; + P.FPercent2:=0; + P.FLightColor1:=clWhite; + P.FDarkColor:=$606060; + P.FLightColor2:=$C0FFFF; + P.FFrameColor1:=$EEE8E8; + P.FFrameColor2:=$B4D4E4; + P.FFillColor1:=$DCD6D6; + P.FFillColor2:=$A0C0D0; + P.FBackFrameColor1:=$9494B4; + P.FBackFrameColor2:=$80809E; + P.FBackFillColor:=$6E6E94; + P.FShadowColor:=$464040; + C.SetSize(204,18); + P.B:=NewBitmap(C.Width,C.Height); + Result:=P; + P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC); + P.NewWind:=integer(MakeObjectInstance(P.NewWndProc)); + SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind); +end; + +destructor TRarProgBar.Destroy; +begin + SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind); + FreeObjectInstance(Pointer(NewWind)); + B.Free; + inherited; +end; + +function TRarProgBar.SetPosition(X,Y: integer): PRarProgBar; +begin + FControl.Left:=X; + FControl.Top:=Y; + Result:=@Self; +end; + +function TRarProgBar.SetSize(X,Y: integer): PRarProgBar; +begin + FControl.Width:=X; + FControl.Height:=Y; + B.Width:=X; + B.Height:=Y; + Result:=@Self; +end; + +function TRarProgBar.SetAlign(A: TControlAlign): PRarProgBar; +begin + FControl.Align:=A; + Result:=@Self; +end; + +procedure TRarProgBar.NewWndProc; +begin + Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam); + case Msg.Msg of + WM_PAINT : Paint; + WM_SIZE : Paint; + WM_ACTIVATE: Paint; + end; +end; + +procedure TRarProgBar.SetMin; +begin + if M>FMax then M:=FMax; + FMin:=M; + Paint; +end; + +procedure TRarProgBar.SetMax; +begin + if MFMax then P:=FMax; + FPosition1:=P; + Paint; +end; + +procedure TRarProgBar.SetPos2; +begin + if FDouble then if P>FPosition1 then P:=FPosition1; + FPosition2:=P; + Paint; +end; + +procedure TRarProgBar.SetDouble; +begin + FDouble:=D; + Paint; +end; + +procedure TRarProgBar.SetLightColor1; +begin + FLightColor1:=C; + Paint; +end; + +procedure TRarProgBar.SetLightColor2; +begin + FLightColor2:=C; + Paint; +end; + +procedure TRarProgBar.SetDarkColor; +begin + FDarkColor:=C; + Paint; +end; + +procedure TRarProgBar.SetFrameColor1; +begin + FFrameColor1:=C; + Paint; +end; + +procedure TRarProgBar.SetFrameColor2; +begin + FFrameColor2:=C; + Paint; +end; + +procedure TRarProgBar.SetFillColor1; +begin + FFillColor1:=C; + Paint; +end; + +procedure TRarProgBar.SetFillColor2; +begin + FFillColor2:=C; + Paint; +end; + +procedure TRarProgBar.SetBackFrameColor1; +begin + FBackFrameColor1:=C; + Paint; +end; + +procedure TRarProgBar.SetBackFrameColor2; +begin + FBackFrameColor2:=C; + Paint; +end; + +procedure TRarProgBar.SetBackFillColor; +begin + FBackFillColor:=C; + Paint; +end; + +procedure TRarProgBar.SetShadowColor; +begin + FShadowColor:=C; + Paint; +end; + +procedure TRarProgBar.Paint; +var R: real; + Prog: cardinal; +begin + TopX:=2; + TopY:=2; + SizeX:=FControl.Width-TopX-2; + SizeY:=FControl.Height-TopY-4; + if (SizeX=0) or (SizeY=0) or (FMax-FMin=0) then Exit; + +/////////////////////////////////////////////////////////////////////////////// +// Рисуем основу +/////////////////////////////////////////////////////////////////////////////// + + B.Canvas.Brush.BrushStyle:=bsSolid; + B.Canvas.Brush.Color:=FControl.Color; + B.Canvas.FillRect(Bounds(0,0,B.Width,B.Height)); + B.Canvas.Brush.Color:=FShadowColor; + B.Canvas.FillRect(Bounds(TopX+1,TopY+2,SizeX,SizeY)); + B.Canvas.Brush.Color:=FBackFillColor; + B.Canvas.FillRect(Bounds(TopX,TopY,SizeX,SizeY+1)); + B.Canvas.Brush.Color:=FDarkColor; + B.Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY+1)); + B.Canvas.Brush.Color:=FBackFrameColor1; + B.Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY)); + B.Canvas.Brush.Color:=FBackFrameColor2; + B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,SizeX-2,SizeY-2)); + +/////////////////////////////////////////////////////////////////////////////// +// Рисуем первый индикатор +/////////////////////////////////////////////////////////////////////////////// + + R:=(FPosition1-FMin)/((FMax-FMin)/SizeX); + Prog:=Round(R); + FPercent1:=Byte(Round(R/(SizeX/100))); + if Prog<>0 then + begin + B.Canvas.Brush.Color:=FLightColor1; + B.Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2)); + if Prog>1 then + begin + B.Canvas.Brush.Color:=FFillColor1; + B.Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); + B.Canvas.Brush.Color:=FFrameColor1; + B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); + end; + B.Canvas.Brush.Color:=FDarkColor; + B.Canvas.FillRect(Bounds(TopX+Prog,TopY,1,TopY+SizeY-1)); + if Prog0 then + begin + B.Canvas.Brush.Color:=FLightColor2; + B.Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2)); + if Prog>1 then + begin + B.Canvas.Brush.Color:=FFillColor2; + B.Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); + B.Canvas.Brush.Color:=FFrameColor2; + B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); + end; + end; + end; + FControl.Canvas.CopyRect(Bounds(0,0,FControl.Width,FControl.Height),B.Canvas,Bounds(0,0,B.Width,B.Height)); +end; + +procedure TRarProgBar.Add1; +begin + Inc(FPosition1,D); + Paint; +end; + +procedure TRarProgBar.Add2; +begin + Inc(FPosition2,D); + Paint; +end; + +end. + diff --git a/Addons/KOLRas.pas b/Addons/KOLRas.pas new file mode 100644 index 0000000..120a322 --- /dev/null +++ b/Addons/KOLRas.pas @@ -0,0 +1,386 @@ +{$A+} + +unit KOLRas; + +interface + +uses + Windows, KOL, RAS; + +type + + PRASObj =^TRASObj; + TKOLRAS = PRASObj; + TOnErrorEvent = procedure (Sender: PRASObj; Error: Integer) of object; + TOnConnectingEvent = procedure (Sender: PRASObj; Msg: Integer; State: Integer; Error: Longint) of object; + + TRASObj = object(TObj) + private + FOnConnecting: TOnConnectingEvent; // event for asynchronous dialing + FOnError: TOnErrorEvent; // error event + FRASHandle: THRasConn; // connection handle + FRASName: string; // name of the RAS service + fState: TRASConnState; + fError: longint; + fTimer: PTimer; + connecting: boolean; + function GetConnected: Boolean; + function GetParams(Server: string; var DialParams: TRasDialParams): Boolean; + function GetPassword: string; + procedure GetRASHandle; + function GetUsername: string; + procedure SetRASName( Value: string ); + function GetStatusString: string; + function GetErrorString: string; + procedure OnTimer(Sender: PObj); + public + destructor Destroy; virtual; // and destroy it + procedure Connect; // make a connection + procedure DisConnect(force: boolean); // close the connection + property Connected: Boolean read GetConnected; // is service connected? + property Status: TRASConnState read fState; // current RAS state + property Error: longint read fError; // last RAS error + property RASHandle: THRASConn read fRASHandle; + property StatusString: string read GetStatusString; + property ErrorString: string read GetErrorString; + property Password: string read GetPassword; // get the password + property RASName: string read FRASName write SetRASName; // name of RAS service + property Username: string read GetUsername; // username + property OnConnecting: TOnConnectingEvent read FOnConnecting write FOnConnecting; // asynch dialing event + property OnError: TOnErrorEvent read FOnError write FOnError; // error event + end; + +function GetStatString(s: longint): string; +function GetErrString(e: longint): string; +function NewRASObj: PRASObj; +function GetRASConnected(Handles: PList): PStrList; // get all existing connections +function GetRASNames: PStrList; // get all possible connections +function IsRASConnected( const r: string ): Boolean; // test if a connection is available +procedure HangUp( const RASName: string ); + +implementation + +var RASSave: PRASObj; + CBkSave: TOnConnectingEvent; + +procedure RASCallback(Msg: Integer; State: TRasConnState; Error: Longint); stdcall; +begin + if assigned(RASSave) then begin + RASSAve.fState := State; + RASSave.fError := Error; + if Assigned(CBkSave) then begin + CBkSave( RASSave, Msg, State, Error ); + end; + if (Assigned(RASSave.FOnError)) and (Error<>0) then begin + RASSave.FOnError( RASSave, Error ); + end; + if State = $2000 then begin + RASSave.fTimer.Enabled := True; + RASSave.connecting := false; + end; + end; +end; + +function NewRASObj; +begin + New(Result, create); // create the component first + Result.FRASHandle := 0; // internal RAS handle + Result.FRASName := ''; // no default RAS name + Result.fTimer := NewTimer(1000); // watchdog timer + Result.fTimer.Enabled := True; + Result.fTimer.Enabled := False; + Result.fTimer.OnTimer := Result.OnTimer; + RASSave := Nil; + CBkSave := Nil; +end; + +destructor TRASObj.Destroy; +begin + DisConnect(True); + RASSave := Nil; + CBkSave := Nil; + fTimer.Free; + inherited Destroy; // next destroy the object +end; + +procedure TRASObj.Connect; +var DialParams: TRasDialParams; // local dial parameters +begin + if not Connected then begin // only if the service is not connected + if GetParams( FRASName, DialParams ) then begin // get actual dial parameters + connecting := true; + RASSave := @self; // save the object itself + CbkSave := FOnConnecting; + RasDial(nil, nil, DialParams, 0, @RASCallback, FRASHandle ); // call with a callback function + end; + end; +end; + +procedure TRASObj.DisConnect; +var s: TRasConnStatus; +begin + if Connected or force then begin // only if a connection is available + if FRASHandle<>0 then begin // only if a vaild handle is available + RasHangup( FRASHandle ); // hangup the RAS service + s.dwSize := sizeof(s); + repeat + sleep(0); + until RasGetConnectStatus( FRASHandle, s ) = ERROR_INVALID_HANDLE; + FRASHandle := 0; + end; + end; +end; + +function TRASObj.GetConnected: Boolean; +begin + Result := IsRASConnected( FRASName ); // test if a service with this name is established + if (Result) and (FRASHandle=0) then begin // if no handle is available + GetRASHandle; // try to read the handle + end; +end; + +function TRASObj.GetParams(Server: string; var DialParams: TRasDialParams): Boolean; +var DialPassword: LongBool; + RASResult: LongInt; +begin + Result := true; // result is first vaild + FillChar( DialParams, SizeOf(TRasDialParams), 0); // clear the result record + DialParams.dwSize := Sizeof(TRasDialParams); // set the result array size + StrPCopy(DialParams.szEntryName, Server); // set the ras service name + DialPassword := true; // get the dial password + RASResult := RasGetEntryDialParams(nil, DialParams, DialPassword); // read the ras parameters + if (RASResult<>0) then begin // if the API call was not successful + Result := false; // result is not vaild + if (Assigned(FOnError)) then begin // if an error event is assigned + FOnError( @self, RASResult ); // call the error event + end; + end; +end; + +function TRASObj.GetPassword: string; +var DialParams: TRasDialParams; // dial parameters for this service +begin + if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful + Result := DialParams.szPassword; // copy the password string + end else begin // if read was not successful + Result := ''; // return an empty string + end; +end; + +procedure TRASObj.GetRASHandle; +const cMaxRas = 100; // maximum number of ras services +var BufferSize: LongInt; // used for size of result buffer + RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself + RASCount: LongInt; // number of found ras services + i: Integer; // loop counter +begin + FRASHandle := 0; // first no handle is available + FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer + RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record + BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size + if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin + for i := 1 to RASCount do begin // for all found ras services + if RASBuffer[i].szEntryName = RASName then begin // if the actual name is available + FRASHandle := RASBuffer[i].hrasconn; // save the found ras handle + end; + end; + end; +end; + +function TRASObj.GetUsername: string; +var DialParams: TRasDialParams; // dial parameters for this service +begin + if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful + Result := DialParams.szUserName; // copy the user name string + end else begin // if read was not successful + Result := ''; // return an empty string + end; +end; + +function TRASObj.GetStatusString; +begin + result := GetStatString(fState); +end; + +function GetStatString; +begin + result := 'unexpected status: ' + int2str(s); + case s of + 0: result := ''; + 1: result := 'port is opened'; + 2: result := 'call in progress'; + 3: result := 'device is connected'; + 4: result := 'all devices is connected'; + 5: result := 'authentication'; + 6: result := 'authnotify'; + 7: result := 'authretry'; + 8: result := 'authcallback'; + 9: result := 'authchangepassword'; + 10: result := 'authproject'; + 11: result := 'linkspeed'; + 12: result := 'authack'; + 13: result := 'reauthenticate'; + 14: result := 'authenticated'; + 15: result := 'prepareforcallback'; + 16: result := 'waitformodemreset'; + 17: result := 'waitforcallback'; + 18: result := 'projected'; + 19: result := 'startauthentication'; + 20: result := 'callbackcomplete'; + 21: result := 'logonnetwork'; +$1000: result := 'interactive'; +$1001: result := 'retryauthentication'; +$1002: result := 'callbacksetbycaller'; +$1003: result := 'password is expired'; +$2000: result := 'connected'; +$2001: result := 'disconnected'; + end; +end; + +function TRASObj.GetErrorString; +begin + result := GetErrString(fError); +end; + +function GetErrString(e: longint): string; +begin + result := 'unexpected error: ' + int2str(e); + case e of + 000: result := ''; + 600: result := 'operation is pending'; + 601: result := 'invalid port handle'; + 608: result := 'device does not exist'; + 615: result := 'port not found'; + 619: result := 'connection is terminated'; + 628: result := 'port was disconnected'; + 629: result := 'disconnected by remote'; + 630: result := 'hardware failure'; + 631: result := 'user disconnect'; + 633: result := 'port is in use'; + 638: result := 'PPP no address assigned'; + 651: result := 'device error'; + 676: result := 'line is busy'; + 678: result := 'no answer'; + 680: result := 'no dialtone'; + 691: result := 'authentication failure'; + 718: result := 'PPP timeout'; + 720: result := 'PPP no CP configured'; + 721: result := 'PPP no responce'; + 732: result := 'PPP is not converging'; + 734: result := 'PPP LCP terminated'; + 735: result := 'PPP adress rejected'; + 738: result := 'no PPP address assigned'; + 742: result := 'no remote encription'; + 743: result := 'remote requires encription'; + 752: result := 'script syntax error'; + 777: result := 'no answer timeout'; + 797: result := 'modem is not found'; + end; +end; + +procedure TRASObj.SetRASName( Value: string ); +var DialParams: TRasDialParams; // dial parameters for this service +begin + if GetParams( Value, DialParams ) then begin + FRASName := Value; + GetRASHandle; // try to read an existing handle + end; +end; + +function GetRASConnected; +const cMaxRas = 100; // maximum number of ras services +var BufferSize: LongInt; // used for size of result buffer + RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself + RASCount: LongInt; // number of found ras services + i: Integer; // loop counter +begin + FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer + RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record + BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size + Result := NewStrList; + if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin + for i := 1 to RASCount do begin // for all found ras services + Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service + if Handles <> nil then Handles.Add(pointer(RASBuffer[i].hrasconn)); + end; + end; + if assigned(RASSave) then begin + if RASSAve.FRASHandle <> 0 then begin + if RASSave.connecting then begin + i := Result.IndexOf(RASSave.FRASName); + if i = -1 then begin + i := Result.Add(RASSave.FRASName); + if Handles <> nil then Handles.Add(pointer(RASSave.FRASHandle)); + end; + if Handles <> nil then Handles.Items[i] := pointer(RASSave.FRASHandle); + end; + end; + end; +end; + +function GetRASNames; +const cMaxRas = 100; // maximum number of ras services +var BufferSize: LongInt; // used for size of result buffer + RASBuffer: array[1..cMaxRas] of TRasEntryName; // the API result buffer itself + RASCount: LongInt; // number of found ras services + i: Integer; // loop counter +begin + Result := Nil; + FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer + RASBuffer[1].dwSize := SizeOf(TRasEntryname); // set the API buffer size for a single record + BufferSize := SizeOf(TRasEntryName) * cMaxRas;// calc complete buffer size + if RasEnumEntries(nil, nil, @RASBuffer[1], BufferSize, RASCount) = 0 then begin + Result := NewStrList; + for i := 1 to RASCount do begin // for all found ras services + Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service + end; + end; +end; + +function IsRASConnected( const r: string ): Boolean; +var n: PStrList; // result object for connected services + i: Integer; // loop counter + p: PList; +begin + Result := false; // first the result is false + p := NewList; + n := GetRasConnected(p); // create the object for connected services + for i := 0 to n.Count - 1 do begin // for all connected services + if r = n.Items[i] then begin // if the ras name was found + Result := true; // the result is true now + Break; // break the loop, one is found + end; + end; + n.Free; // destroy the object for connected services + p.Free; +end; + +procedure HangUP; +var e: PStrList; + h: PList; + i: integer; +begin + h := NewList; + e := GetRASConnected(h); + i := e.IndexOf(RASName); + if i > -1 then begin + RASHangUp(integer(h.Items[i])); + end; + e.Free; + h.Free; +end; + +procedure TRASObj.OnTimer; +begin + if not connected then begin + fTimer.Enabled := False; + Disconnect(True); + if assigned(fOnConnecting) then begin + fState := $2001; + fError := 619; + fOnConnecting(@self, 0, $2001, 619); + end; + end; +end; + +end. diff --git a/Addons/KOLReport.dcr b/Addons/KOLReport.dcr new file mode 100644 index 0000000000000000000000000000000000000000..63ab373ddf0e1c7451bceaca60383cbc3a23b45d GIT binary patch literal 1368 zcmd5*u}TCn5SM^nX(3z<|XS$;YI-!eV@rWcRXg z9%7@zCiC`XGMVHhL_{+*=G*{B_BJ890>gYl&vZ|Zw4ycL(G$=bOmEZa`Du?Y0M1IA zP^M?dbJ#i}eAIQ>p$A0k$T^1rDNGz^hd$TJ6hhdx?F(E8T5n&OcdcM+wbslmBj(du zgXud2TD!1@IbtZ<1rJy;oA<&i#EOB73Z2+doWrG;_%uUt{2tfwIlc5zMaGAnVX}%b z7nyicQOF!4BQS|ce8j=TQfA7tPfsM;U4p2!Tha|Z(CrZR7rK4uxyY2vTci75KeyJF zA#XQ+z?(2&O!B_Wt(_ZoM2(Y^$Tr3}Ey#qX8kcT?bict>o_;0f@mdm+t*Pt$2^QVv zm|N>szqu7OT;dI`$^!paLo?{+%~-?h0|(*Ce&E7h!zfs;xx50wa^G<_1(WJANEu4} Z2uBGie2wL?_527YO_8Un=RmnfsV`}poxT77 literal 0 HcmV?d00001 diff --git a/Addons/KOLReport.pas b/Addons/KOLReport.pas new file mode 100644 index 0000000..76c1f94 --- /dev/null +++ b/Addons/KOLReport.pas @@ -0,0 +1,1277 @@ +{ KOLReport v2.0 (C) 2002 by Vladimir Kladov. + + See Demo project attached for documentation. All other documentation planned + to be added later. + + In version 2.0: + [+] metafiles used, spooling size became less, printing quality increased. + [+] with new version of KOLPrinters by Boguslaw Brandys, printer setup dialog provided. +} +unit KOLReport; + +interface + +//{$DEFINE use_MHPRINTER} +// (uncomment line above to use TKOLMHPrinter prior to TKOLPrinter) + +uses Windows, Messages, KOL, + {$IFDEF use_MHPRINTER} KOLMHPrinters + {$ELSE} KOLPrinters, KOLPageSetupDialog + {$ENDIF}; + +type + {$IFDEF use_MHPRINTER} PPrinter = PMHPrinter; {$ENDIF} + + TPaperSize = ( psA4, psA5, psA6, psA3, psLetter, psCustom ); + {* Available paper sizes. } + TBandLayout = ( blLeft, blCenter, blRight, blExpandRight ); + {* Available band layouts. } + TMargins = TRect; + + TMF = HDC; // used as a handle to memory-based EnhMetafile. + + PReport = ^TReport; + + PPreviewObj = ^TPreviewObj; + TPreviewObj = object( TObj ) + {* Preview form container object. } + private + procedure SetCurPage(const Value: Integer); + procedure SetFitMode(const Value: Integer); + public + Form: PControl; + {* Form. } + TB: PControl; + {* Toolbar. } + SB: PControl; + {* Scrollbar. } + PB: PControl; + {* PaintBox. } + LB: PControl; + PSD: PPageSetupDlg; {Brandys} + Options: TPageSetupOptions; + {* Label to show current page number and total pages count. } + FFitMode: Integer; + {* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1 } + ViewMenu: PMenu; + {* Drop down menu for toolbar button TBView. } + FBuf: PBitmap; + {* Buffer where current page stored (scaled). } + protected + FReport: PReport; + {* Reference to parent Report object. } + FCurPage: Integer; + {* Current page index. } + FBufPage: Integer; + {* Buffered page index. } + procedure TBClick( Sender: PObj ); + procedure TBDropDownViewMenu( Sender: PObj ); + procedure TBViewMenuClick( Sender: PMenu; Item: Integer ); + procedure AdjustButtons( Sender: PObj ); + procedure PaintPage( Sender: PControl; DC: HDC ); + procedure AdjustFitMode; + procedure PrinterSetup; + procedure ResizePreviewForm( Sender: PObj ); + public + destructor Destroy; virtual; + {* } + property CurPage: Integer read FCurPage write SetCurPage; + {* Current page index (starting from 0). } + function PageCount: Integer; + {* Total pages count. Could be 0, if a report is empty (nothing to show). } + procedure PrintAllPages; + {* Call this method to print all pages. } + property FitMode: Integer read FFitMode write SetFitMode; + {* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1. } + end; + + TReport = object( TObj ) + {* Report object. It is used to create report and to print or preview it} + private + FDocName: String; + FReplaceFontHeight0: Integer; + FMargins: TMargins; + function GetPages(Idx: Integer): TMF; + function GetImages(Idx: Integer): HENHMETAFILE; + procedure SetMargins(const Value: TMargins); + function GetMarginsPixels( const Index: Integer ): TMargins; + protected + FPageTop: Boolean; + FY: Integer; + FOnNewPage: TOnEvent; + FPrinter: PPrinter; + FX: Integer; + FPrinting: Boolean; + FDCPages: PList; + FHDPages: PList; + FStage: Integer; + FOnPrint: TOnEvent; + FPreviewForm: PPreviewObj; + FBottom: Integer; + FPagePixelsSize: TSize; + FPaperSize: TPaperSize; + FCustomPaperSize: TSize; + FPageWidth: Integer; + FPageHeight: Integer; + FDoubleBufferedPreview: Boolean; + FCurBandHeight: Integer; + FOnEndBand: TOnEvent; + fNewPageHandling: Boolean; + fNewBandHandling: Boolean; + procedure SetPageTop(const Value: Boolean); + procedure SetPrinter(const Value: PPrinter); + function GetPageCount: Integer; + function GetPreviewForm: PPreviewObj; + procedure SetPreviewForm(const Value: PPreviewObj); + function GetCurrentPage: TMF; + function GetPrinter: PPrinter; + function GetPagePixelsSize: TSize; + function GetOrientation: TPrinterOrientation; + procedure SetPaperSize(const Value: TPaperSize); + procedure SetCustomPaperSize(const Value: TSize); + function GetPageHeight: Integer; + function GetPageWidth: Integer; + procedure GetPageWidthHeight; + procedure SetX(const Value: Integer); + procedure SetY(const Value: Integer); + protected + function AddPage: TMF; + function PaintBand( MF: TMF; Band: PControl; Xpos, Ypos: Integer ): Integer; + function ScaleX( W: Integer ): Integer; + function ScaleY( H: Integer ): Integer; + procedure DoPrintPreview( Proc: TObjectMethod ); + procedure DoPrint; + procedure DoPreview; + procedure DoPreviewModal; + public + Destructor Destroy; virtual; + procedure Clear; + {* Call this method to make report empty. If the preview form is active + for the report, it is closed too. } + procedure ClearPages; + {* Clears all pages. } + property PreviewForm: PPreviewObj read GetPreviewForm write SetPreviewForm; + {* Access to preview form object. } + property DoubleBufferedPreview: Boolean read FDoubleBufferedPreview write FDoubleBufferedPreview; + {* Set this value to TRUE, if you wish from PreviewForm to be shown + DoubleBuffered. } + property PagePixelsSize: TSize read GetPagePixelsSize; + {* Size of a page in screen pixels. } + property Orientation: TPrinterOrientation read GetOrientation; + {* Orientation of a Printer. } + property PaperSize: TPaperSize read FPaperSize write SetPaperSize; + {* Paper size type (psA4, psA3, ... psCustom). } + property CustomPaperSize: TSize read FCustomPaperSize write SetCustomPaperSize; + {* Custom paper size in millimeters. } + property PageWidth: Integer read GetPageWidth; + {* Paper width in Printer canvas pixels. } + property PageHeight: Integer read GetPageHeight; + {* Paper height in Printer canvas pixels. } + property CurrentPage: TMF read GetCurrentPage; + {* Current page metafile DC. Valid only while drawing the page. } + property Printer: PPrinter read GetPrinter write SetPrinter; + {* Printer object. } + property PageTop: Boolean read FPageTop write SetPageTop; + {* True, if current position is on top of current page. (It is set to + True just after calling OnNewPage event, i.e. *after* printing top + page colontitles). } + property X: Integer read FX write SetX; + {* Current X position. } + property Y: Integer read FY write SetY; + {* Current Y position. } + public + procedure AddBand( Band: PControl ); + {* Call this method to add a band. Band could be any control, not only + created with NewBand or NewReportLabel etc. Before adding a band, + change its contant as you wish (change Caption, adjust Frames, Color, + Font, etc.) } + procedure AddBandEx( Band: PControl; BandLayout: TBandLayout ); + {* Call this method to add a band with special aligning option. } + procedure AddFooter( Band: PControl ); + {* Adds a footer band to a current page. It is possible to add several + footers, in such case the first is added to the bottom, and all the + follows above it. } + procedure AddFooterEx( Band: PControl; BandLayout: TBandLayout ); + {* Adds a footer with special aligning option. } + procedure AddRight( Band: PControl ); + {* Adds a band or a cell just right, without shifting current Y position + onto a height of a Band, like in AddBand or AddBandEx. Calling + AddRight ands AddRightEx several times it is possible to construct + desired band from prepared cells dynamically. If there are no place + for a new band between X position and right margin of the page, new + band is added from the starting of the next horizontal band + automatically. } + procedure AddRightEx( Band: PControl; BandLayout: TBandLayout ); + {* Adds a band or a cell just right, and with additional layout options. } + procedure NewPage; + {* Forces new page. If called twice, empty page will be printed. } + property Bottom: Integer read FBottom; + {* Bottom available position (in screen pixels). Valid while drawing + onto current page. } + property PageCount: Integer read GetPageCount; + {* Total number of pages. } + property Pages[ Idx: Integer ]: TMF read GetPages; + {* Access to pages metafiles DC. Valid while drawing pages. } + property Images[ Idx: Integer ]: HENHMETAFILE read GetImages; + {* Access to page metafiles handles. If a handle for a certain page + is accessed, its metafile DC become unavailable. } + procedure Print; + {* Call this method to print all the pages. } + procedure PrintPages( FromPage, ToPage: Integer ); + {* Call this method to print given pages range. } + procedure Preview; + {* Call this method to show preview non-modal. Be sure, that the Report + object is existing while preview is active. } + procedure PreviewModal; + {* Call this method to show preview form modal. } + procedure Abort; + {* Call this method to stop current printing. } + property Printing: Boolean read FPrinting; + {* True, if pages are currently printing. } + property Stage: Integer read FStage; + {* If OnPrint event is called, this value 1 or 2 shows a stage of + printing. In the first call of OnPrint event, it has value 1, in the + second its value is 2. } + property OnPrint: TOnEvent read FOnPrint write FOnPrint; + {* If this event is assigned, perform adding all bands in this event + handler. Please remember, that OnPrint is called twice. Be sure, that + all your initializations made correctly for both stages. Mainly, this + method is used to provide printing some data which depends on total + pages count (e.g. to print Page 1 From 10. You should store total + pages count after stage 1, and use this information on stage 2). + Also, this event allows to repeat printing after showing Printer setup + dialog in case when some settings are changed (page size, layout, + margins, etc.) } + property OnNewPage: TOnEvent read FOnNewPage write FOnNewPage; + {* This event is called when new page is started (by any reason). You can + add here page header or footers, if you wish. } + property OnEndBand: TOnEvent read FOnEndBand write FOnEndBand; + {* This event can be useful when bands are created dynamically from cells + calling AddRight or AddRightEx. } + function HeightAvailable: Integer; + {* Pixels available vertically on current page (in screen pixels). If + this value is not sufficient to add a band, new page is started. It + is possible to check this value manually to ensure that a certain + number of bands could be fit, and to force new page if you wish from + some data to be located always together, e.g. subdetail title + + column header + at least 1 band of subdetail data. } + property DocumentName: String read FDocName write FDocName; + {* Assign a name of your document here. This value is shown in spooler + queue and helps to identify your report among other printing documents. } + property ReplaceFontHeight0: Integer read FReplaceFontHeight0 write FReplaceFontHeight0; + {* Change this value, if default value 18 pixels is not satisfying you. + While adding a band, all its fonts with FontHeight=0 are replaced by this + value to provide correct scaling onto Printer device. } + property Margins: TMargins read FMargins write SetMargins; + {* Margins in 0.01 millimeters. } + property MarginsPrinterPixels: TMargins index 1 read GetMarginsPixels; + {* Margins in Printer's pixels. } + property MarginsScreenPixels: TMargins index 2 read GetMarginsPixels; + {* Margins in screen pixels. } + end; + + TFrame = ( frLeft, frTop, frRight, frBottom ); + {* Frames for special band control. } + TFrames = set of TFrame; + {* } + + TPaddings = packed record + {* Paddings. } + LeftPadding, TopPadding, RightPadding, BottomPadding: Integer; + end; + +const + AllFrames: TFrames = [ frLeft, frTop, frRight, frBottom ]; + {* Use this constant to tell that all the frames are turned on. } + +function NewReport: PReport; +{* Call this function to create report object. } +procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl ); +{* This function is called automatically when Preview or PreviewModal method + is called for TReport object. } + +function NewBand( AParent: PControl; Frames: TFrames ): PControl; +{* Call this function to create special band control. It is very similar to + a panel, and can contain other controls as children. } +function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; +{* Call this function to create band label. It can be used along or as a + child of a band. } +function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; +{* Like NewReportLabel, but with WordWrap. } + +procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer ); +{* Use this function to change band paddings. } + +type + TKOLReport = PReport; + TKOLBand = PControl; + TKOLReportLabel = PControl; + +implementation + +const TBFrst = 0; + TBPrev = 1; + TBNext = 2; + TBLast = 3; + TBPrnt = 4; + TBSetu = 5; + TBView = 6; + TBExit = 7; + +function GetProviderPrinter: PPrinter; +begin + Result := Printer; +end; + +function NewReport: PReport; +begin + new( Result, Create ); + Result.FDocName := 'Report 1'; + Result.FDCPages := NewList; + Result.FHDPages := NewList; + Result.FCustomPaperSize.cx := 210; + Result.FCustomPaperSize.cy := 270; + Result.FReplaceFontHeight0 := -12; + Result.FMargins := MakeRect( 500, 500, 500, 500 ); +end; + +procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl ); +var Pn: PControl; +begin + new( PreviewObj, Create ); + PreviewObj.Form := NewForm( AParent, 'Preview' ).SetSize( 600, 600 ) + .SetPosition( (GetSystemMetrics( SM_CXSCREEN ) - 600) div 2, + (GetSystemMetrics( SM_CYSCREEN ) - 600) div 2 ); + {Brandys} + PreviewObj.Options := [psdMargins,psdSamplePage,psdPaperControl,psdPrinterControl,psdWarning,psdHundredthsOfMillimeters,psdUseMargins,psdUseMinMargins]; + PreviewObj.PSD := NewPageSetupDialog(PreviewObj.Form,PreviewObj.Options); + PreviewObj.PSD.SetMinMargins(500,500,500,500); + PreviewObj.Form.Border := 0; + Pn := NewPanel( PreviewObj.Form, esNone ).SetSize( 0, 25 ).SetAlign( caTop ); + PreviewObj.TB := NewToolbar( Pn, caNone, [ tboNoDivider ], + THandle(-1), [ '<<', '<', '>', '>>', ' Print', 'Setup', '^View', 'Close' ], + [ -1, -1, -1, -1, 14, -2 ] ).SetAlign( caLeft ).SetSize( 440, 0 ); + PreviewObj.TB.OnClick := PreviewObj.TBClick; + PreviewObj.TB.OnTBDropDown := PreviewObj.TBDropDownViewMenu; + NewMenu( PreviewObj.Form, 0, [ '' ], nil ); + PreviewObj.ViewMenu := NewMenu( PreviewObj.Form, 0, + [ '-!Fit &Height', '-!Fit &Width', '-!&1:1' ], + PreviewObj.TBViewMenuClick ); + PreviewObj.LB := NewLabel( Pn, '' ).SetAlign( caClient ); + PreviewObj.LB.TextAlign := taRight; + PreviewObj.LB.VerticalAlign := vaCenter; + PreviewObj.Form.OnShow := PreviewObj.AdjustButtons; + PreviewObj.SB := NewScrollBoxEx( PreviewObj.Form, esLowered ).SetAlign( caClient ); + PreviewObj.PB := NewPaintBox( PreviewObj.SB ); + PreviewObj.PB.OnPaint := PreviewObj.PaintPage; + + //PreviewObj.TB.TBButtonVisible[ TBSetu ] := FALSE; + PreviewObj.Form.OnResize := PreviewObj.ResizePreviewForm; +end; + +type + PFramesData = ^TFramesData; + TFramesData = packed Record + Frames: TFrames; + Paddings: TPaddings; + end; + +procedure PaintFrames( Self_, Sender: PControl; DC: HDC ); +var Br: HBrush; + R: TRect; + procedure FillFrame( X1, Y1, X2, Y2: Integer ); + begin + if X2 <= X1 then Exit; + if Y2 <= Y1 then Exit; + FillRect( DC, MakeRect( X1, Y1, X2, Y2 ), Br ); + end; +var Data: PFramesData; + W, H, B: Integer; + Fmt: DWORD; + OldFont: HFont; + OldBk: Integer; +begin + Data := Self_.CustomData; + Br := CreateSolidBrush( Color2RGB( Self_.Font.Color ) ); + W := Self_.ClientWidth; + H := Self_.ClientHeight; + B := Self_.Border; + R := Self_.ClientRect; + if frLeft in Data.Frames then + begin + FillFrame( 0, 0, B, H ); + Inc( R.Left, B ); + end; + if frTop in Data.Frames then + begin + FillFrame( 0, 0, W, B ); + Inc( R.Top, B ); + end; + if frRight in Data.Frames then + begin + FillFrame( W - B, 0, W, H ); + Dec( R.Right, B ); + end; + if frBottom in Data.Frames then + begin + FillFrame( 0, H - B, W, H ); + Dec( R.Bottom, B ); + end; + DeleteObject( Br ); + + Br := CreateSolidBrush( Color2RGB( Self_.Color ) ); + FillRect( DC, R, Br ); + Inc( R.Left, Data.Paddings.LeftPadding ); + Inc( R.Top, Data.Paddings.TopPadding ); + Dec( R.Right, Data.Paddings.RightPadding ); + Dec( R.Bottom, Data.Paddings.BottomPadding ); + DeleteObject( Br ); + + case Self_.TextAlign of + taCenter: Fmt := DT_CENTER; + taRight: Fmt := DT_RIGHT; + else Fmt := DT_LEFT; + end; + case Self_.VerticalAlign of + vaTop: Fmt := Fmt or DT_TOP; + vaCenter: Fmt := Fmt or DT_VCENTER; + vaBottom: Fmt := Fmt or DT_BOTTOM; + end; + if Self_.WordWrap then + Fmt := Fmt or DT_WORDBREAK + else + Fmt := Fmt or DT_SINGLELINE; + OldFont := SelectObject( DC, Self_.Font.Handle ); + + OldBk := SetBkMode( DC, TRANSPARENT ); + DrawText( DC, PChar( Self_.Caption ), Length( Self_.Caption ), R, Fmt ); + SetBkMode( DC, OldBk ); + SelectObject( DC, OldFont ); + +end; + +function NewBand( AParent: PControl; Frames: TFrames ): PControl; +var Data: PFramesData; +begin + Result := NewPanel( AParent, esNone ); + Result.Color := clWhite; + Result.Border := 1; + Data := AllocMem( Sizeof( TFramesData ) ); + Result.CustomData := Data; + Data.Frames := Frames; + Data.Paddings.LeftPadding := 4; + Data.Paddings.RightPadding := 4; + Result.OnPaint := TOnPaint( MakeMethod( Result, @ PaintFrames ) ); + Result.Width := 400; + Result.Height := 40; + Result.fCommandActions.aAutoSzX := 12; +end; + +procedure InitBandLabel( L: PControl; Frames: TFrames ); +var Data: PFramesData; +begin + L.Color := clWhite; + L.Border := 1; + Data := AllocMem( Sizeof( TFramesData ) ); + L.CustomData := Data; + Data.Frames := Frames; + Data.Paddings.LeftPadding := 4; + Data.Paddings.RightPadding := 4; + L.OnPaint := TOnPaint( MakeMethod( L, @ PaintFrames ) ); + L.fCommandActions.aAutoSzX := 12; +end; + +function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; +begin + Result := NewLabel( AParent, Caption ).AutoSize( TRUE ); + InitBandLabel( Result, Frames ); +end; + +function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; +begin + Result := NewWordWrapLabel( AParent, Caption ).AutoSize( TRUE ); + InitBandLabel( Result, Frames ); +end; + +procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer ); +var Data: PFramesData; + WasHPadding: Integer; +begin + Data := BandCtl.CustomData; + WasHPadding := Data.Paddings.LeftPadding + Data.Paddings.RightPadding; + Data.Paddings.LeftPadding := LeftPadding; + Data.Paddings.TopPadding := TopPadding; + Data.Paddings.RightPadding := RightPadding; + Data.Paddings.BottomPadding := BottomPadding; + BandCtl.fCommandActions.aAutoSzX := BandCtl.fCommandActions.aAutoSzX - + WasHPadding + LeftPadding + RightPadding; + if BandCtl.IsAutoSize then + BandCtl.AutoSize( TRUE ); +end; + +{ TReport } + +procedure TReport.Abort; +begin + Clear; + if Assigned( FPrinter ) then + begin + if Printer.Printing then + Printer.Abort; + end; +end; + +procedure TReport.AddBand(Band: PControl); +begin + AddBandEx( Band, blLeft ); +end; + +procedure TReport.AddBandEx(Band: PControl; BandLayout: TBandLayout); +var MF: TMF; + OldW: Integer; +begin + if FCurBandHeight > 0 then + begin + if not fNewBandHandling then + if Assigned( OnEndBand ) then + begin + fNewBandHandling := TRUE; + OnEndBand( @ Self ); + fNewBandHandling := FALSE; + end; + FX := MarginsScreenPixels.Left; + FY := FY + FCurBandHeight; + end; + if Band.Height > HeightAvailable then + NewPage; + MF := CurrentPage; + case BandLayout of + blLeft: FY := FY + PaintBand( MF, Band, X, Y ); + blRight: FY := FY + PaintBand( MF, Band, PagePixelsSize.cx - Band.Width, Y ); + blCenter: FY := FY + PaintBand( MF, Band, (PagePixelsSize.cx - Band.Width) div 2, Y ); + blExpandRight: begin + OldW := Band.Width; + try + Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X; + FY := FY + PaintBand( MF, Band, X, Y ); + finally + Band.Width := OldW; + end; + end; + end; + FPageTop := FALSE; + FCurBandHeight := 0; +end; + +procedure TReport.AddFooter(Band: PControl); +begin + AddFooterEx( Band, blLeft ); +end; + +procedure TReport.AddFooterEx(Band: PControl; BandLayout: TBandLayout); +var MF: TMF; + OldW: Integer; +begin + if Band.Height > HeightAvailable then + NewPage; + MF := CurrentPage; + case BandLayout of + blLeft: FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height ); + blRight: FBottom := FBottom - PaintBand( MF, Band, + PagePixelsSize.cx - Band.Width, FBottom - Band.Height ); + blCenter: FBottom := FBottom - PaintBand( MF, Band, + (PagePixelsSize.cx - Band.Width) div 2, FBottom - Band.Height ); + blExpandRight: begin + OldW := Band.Width; + try + Band.Width := PagePixelsSize.cx - + MarginsScreenPixels.Left - MarginsScreenPixels.Right; + FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height ); + finally + Band.Width := OldW; + end; + end; + end; +end; + +function TReport.AddPage: TMF; +var MF: TMF; + R: TRect; + DC0: HDC; +begin + DC0 := GetDC( 0 ); + R := MakeRect( 0, 0, + MulDiv(PagePixelsSize.cx, GetDeviceCaps(DC0, HORZSIZE)*100, GetDeviceCaps(DC0, HORZRES)), + MulDiv(PagePixelsSize.cy, GetDeviceCaps(DC0, VERTSIZE)*100, GetDeviceCaps(DC0, VERTRES)) ); + + MF := CreateEnhMetaFile( DC0, nil, @ R, '' ); + ReleaseDC( 0, DC0 ); + + FDCPages.Add( Pointer( MF ) ); + Result := MF; + FPageTop := TRUE; + FBottom := PagePixelsSize.cy - MarginsScreenPixels.Bottom; + if not fNewPageHandling then + if Assigned( OnNewPage ) then + begin + fNewPageHandling := TRUE; + OnNewPage( @ Self ); + fNewPageHandling := FALSE; + end; +end; + +procedure TReport.AddRight(Band: PControl); +begin + AddRightEx( Band, blLeft ); +end; + +procedure TReport.AddRightEx(Band: PControl; BandLayout: TBandLayout); +var MF: TMF; + OldW: Integer; +begin + if Band.Height > HeightAvailable then + NewPage; + MF := CurrentPage; + if Band.Width > PagePixelsSize.cx - MarginsScreenPixels.Right - X then + begin + if not fNewBandHandling then + if Assigned( OnEndBand ) then + begin + fNewBandHandling := TRUE; + OnEndBand( @ Self ); + fNewBandHandling := FALSE; + end; + FX := MarginsScreenPixels.Left; + FY := FY + FCurBandHeight; + FCurBandHeight := 0; + end; + case BandLayout of + blLeft: PaintBand( MF, Band, X, Y ); + blRight: PaintBand( MF, Band, X + PagePixelsSize.cx - Band.Width, Y ); + blCenter: PaintBand( MF, Band, X + (PagePixelsSize.cx - X - Band.Width) div 2, Y ); + blExpandRight: begin + OldW := Band.Width; + try + Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X; + PaintBand( MF, Band, X, Y ); + finally + Band.Width := OldW; + end; + end; + end; + FX := X + Band.Width; + if FCurBandHeight < Band.Height then + FCurBandHeight := Band.Height; + FPageTop := FALSE; +end; + +procedure TReport.Clear; +begin + if FPreviewForm <> nil then + FPreviewForm.Form.Free; + ClearPages; +end; + +destructor TReport.Destroy; +begin + Clear; + FDCPages.Free; + FHDPages.Free; + FDocName := ''; + inherited; +end; + +procedure TReport.DoPreview; +begin + if PageCount = 0 then Exit; + PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview; + PreviewForm.FReport := @ Self; + PreviewForm.Form.Caption := FDocName; + PreviewForm.Form.Show; +end; + +procedure TReport.DoPreviewModal; +begin + if PageCount = 0 then Exit; + PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview; + PreviewForm.FReport := @ Self; + PreviewForm.Form.Caption := FDocName; + PreviewForm.Form.ShowModal; + FPreviewForm.Form.Free; + FPreviewForm := nil; +end; + +procedure TReport.DoPrint; +begin + PrintPages( 0, PageCount-1 ); +end; + +procedure TReport.DoPrintPreview(Proc: TObjectMethod); +begin + if Printing then Abort; + if Assigned( FOnPrint ) then + begin + Clear; + FStage := 1; + FOnPrint( @ Self ); + if PageCount = 0 then Exit; + Clear; + FStage := 2; + FOnPrint( @ Self ); + end; + Proc; +end; + +function TReport.GetCurrentPage: TMF; +begin + if PageCount = 0 then + Result := AddPage + else + Result := Pages[ PageCount-1 ]; +end; + +function TReport.GetOrientation: TPrinterOrientation; +begin + Result := Printer.Orientation; +end; + +function TReport.GetPageHeight: Integer; +begin + GetPageWidthHeight; + Result := FPageHeight; +end; + +function TReport.GetPagePixelsSize: TSize; +var I: Integer; + P: TPoint; + DC0: HDC; +begin + if (FPagePixelsSize.cx = 0) or (FPagePixelsSize.cy = 0) then + begin + case PaperSize of + psA3: P := MakePoint( 297, 420 ); + psA4: P := MakePoint( 210, 297 ); + psA5: P := MakePoint( 148, 210 ); + psA6: P := MakePoint( 105, 148 ); + psLetter: P := MakePoint( 216, 280 ); + else P := MakePoint( FCustomPaperSize.cx, FCustomPaperSize.cy ); + end; + DC0 := GetDC( 0 ); + FPagePixelsSize.cx := Round( (P.x * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSX ) ); + FPagePixelsSize.cy := Round( (P.y * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSY ) ); + ReleaseDC( 0, DC0 ); + end; + Result := FPagePixelsSize; + if Orientation = poLandscape then + begin + I := Result.cx; + Result.cx := Result.cy; + Result.cy := I; + end; +end; + +function TReport.GetPageCount: Integer; +begin + Result := FDCPages.Count; +end; + +function TReport.GetPageWidth: Integer; +begin + GetPageWidthHeight; + Result := FPageWidth; +end; + +procedure TReport.GetPageWidthHeight; +begin + if (FPageWidth <> 0) and (FPageHeight <> 0) then Exit; + if Printer.Printing then + begin + FPageWidth := Printer.PageWidth; + FPageHeight := Printer.PageHeight; + end + else + begin + Printer.BeginDoc; + TRY + FPageWidth := Printer.PageWidth; + FPageHeight := Printer.PageHeight; + FINALLY + Printer.Abort; + END; + end; +end; + +function TReport.GetPreviewForm: PPreviewObj; +begin + if FPreviewForm = nil then + begin + NewPreviewForm( FPreviewForm, Applet ); + FPreviewForm.FReport := @ Self; + end; + Result := FPreviewForm; +end; + +function TReport.GetPrinter: PPrinter; +begin + if FPrinter = nil then + FPrinter := GetProviderPrinter; + Result := FPrinter; +end; + +function TReport.HeightAvailable: Integer; +begin + Result := FBottom - FY; +end; + +procedure TReport.NewPage; +begin + FY := MarginsScreenPixels.Top; + FX := MarginsScreenPixels.Left; + AddPage; +end; + +function TReport.PaintBand(MF: TMF; Band: PControl; Xpos, Ypos: Integer): Integer; + + procedure PaintBandWithChildren( Band: PControl; DC: HDC ); + var I: Integer; + C: PControl; + P0, P: TPoint; + R0, R1, R2: TRect; + Save: Integer; + FontHeight0Replaced: Boolean; + begin + FontHeight0Replaced := FALSE; + if (ReplaceFontHeight0 <> 0) and (Band.Font.FontHeight = 0) then + begin + FontHeight0Replaced := TRUE; + Band.Font.FontHeight := ReplaceFontHeight0; + end; + Band.Perform( WM_PRINT, DC, PRF_NONCLIENT ); + GetClientRect( Band.Handle, R0 ); + P0 := MakePoint( 0, 0 ); + ClientToScreen( Band.Handle, P0 ); + GetWindowOrgEx( DC, P ); + GetWindowRect( Band.Handle, R1 ); + OffsetRect( R0, P0.x - R1.Left, P0.y - R1.Top ); + SetWindowOrgEx( DC, P.x - (P0.x - R1.Left), P.y - (P0.y - R1.Top), @ P ); + IntersectClipRect( DC, R0.Left, R0.Top, R0.Right, R0.Bottom ); + Band.Perform( WM_ERASEBKGND, DC, 0 ); + Band.Perform( WM_PAINT, DC, 0 ); + GetWindowRect( Band.Handle, R1 ); + for I := 0 to Band.ChildCount-1 do + begin + Save := SaveDC( DC ); + C := Band.Children[ I ]; + GetWindowRect( C.Handle, R2 ); + SetWindowOrgEx( DC, P.x - (R2.Left - R1.Left), P.y - (R2.Top - R1.Top), nil ); + IntersectClipRect( DC, 0, 0, R2.Right - R2.Left, R2.Bottom - R2.Top ); + PaintBandWithChildren( C, DC ); + RestoreDC( DC, Save ); + end; + if FontHeight0Replaced then + Band.Font.FontHeight := 0; + end; + +var OldParent: PControl; + WasVisible: Boolean; + WasBR: TRect; + P: TPoint; + Save: Integer; + +begin + OldParent := Band.Parent; + OldParent.CreateWindow; + WasVisible := Band.Visible; + WasBR := Band.BoundsRect; + try + Band.Visible := FALSE; + Band.Parent := Applet; + Band.Top := Applet.Height; + SetParent( Band.GetWindowHandle, Applet.Handle ); + Band.Visible := TRUE; + + Save := SaveDC( MF ); + GetWindowOrgEx( MF, P ); + SetWindowOrgEx( MF, P.x - Xpos, P.y - Ypos, nil ); + + PaintBandWithChildren( Band, MF ); + + SetWindowOrgEx( MF, P.x, P.y, nil ); + RestoreDC( MF, Save ); + + finally + Band.Visible := FALSE; + Band.Parent := OldParent; + SetParent( Band.Handle, OldParent.Handle ); + Band.BoundsRect := WasBR; + Band.Visible := WasVisible; + end; + Result := Band.Height; +end; + +procedure TReport.Preview; +begin + DoPrintPreview( DoPreview ); +end; + +procedure TReport.PreviewModal; +begin + DoPrintPreview( DoPreviewModal ); +end; + +procedure TReport.Print; +begin + DoPrintPreview( DoPrint ); +end; + +function TReport.ScaleX(W: Integer): Integer; +begin + Result := Round( W * Printer.PageWidth / PagePixelsSize.cx ); +end; + +function TReport.ScaleY(H: Integer): Integer; +begin + Result := Round( H * Printer.PageHeight / PagePixelsSize.cy ); +end; + +procedure TReport.SetCustomPaperSize(const Value: TSize); +const PapSizes: array[ TPaperSize, 1..2] of Integer = ( ( 210, 297 ), + ( 148, 210 ), ( 105, 148 ), ( 297, 420 ), (216, 280), ( 0, 0 ) ); +var PSidx: TPaperSize; +begin + FCustomPaperSize := Value; + for PSidx := Low( TPaperSize ) to Pred( High( TPaperSize ) ) do + begin + if (PapSizes[ PSidx ][ 1 ] = Value.cx) and + (PapSizes[ PSidx ][ 2 ] = Value.cy) then + begin + PaperSize := PSidx; + exit; + end; + end; + PaperSize := psCustom; +end; + +procedure TReport.SetPageTop(const Value: Boolean); +begin + FPageTop := Value; +end; + +procedure TReport.SetPaperSize(const Value: TPaperSize); +begin + if FPaperSize = Value then Exit; + if FPrinting then Abort; + FPaperSize := Value; +end; + +procedure TReport.SetPreviewForm(const Value: PPreviewObj); +begin + if FPreviewForm = Value then Exit; + if FPreviewForm <> nil then + FPreviewForm.Form.Free; + FPreviewForm := Value; +end; + +procedure TReport.SetPrinter(const Value: PPrinter); +begin + if FPrinter = Value then Exit; + if FPrinting then Abort; + FPrinter := Value; + FPageWidth := 0; + FPageHeight := 0; +end; + +procedure TReport.SetX(const Value: Integer); +begin + if FX = Value then Exit; + FX := Value; +end; + +procedure TReport.SetY(const Value: Integer); +begin + if FY = Value then Exit; + FY := Value; + FCurBandHeight := 0; +end; + +function TReport.GetPages(Idx: Integer): TMF; +begin + Result := TMF( FDCPages.Items[ Idx ] ); +end; + +function TReport.GetImages(Idx: Integer): HENHMETAFILE; +begin + while FHDPages.Count <= Idx do + FHDPages.Add( nil ); + if FHDPages.Items[ Idx ] = nil then + begin + FHDPages.Items[ Idx ] := Pointer( CloseEnhMetafile( Pages[ Idx ] ) ); + FDCPages.Items[ Idx ] := nil; + end; + Result := HENHMETAFILE( FHDPages.Items[ Idx ] ); +end; + +procedure TReport.PrintPages(FromPage, ToPage: Integer); +var I: Integer; + MF: HENHMETAFILE; + PrintingStarted: Boolean; + N: Integer; +begin + PrintingStarted := FALSE; + TRY + for I := FromPage to ToPage do + begin + MF := Images[ I ]; + if I = 0 then + begin + Printer.Title := FDocName; + Printer.BeginDoc; + PrintingStarted := TRUE; + end; + N := 1; + while PageWidth > PagePixelsSize.cx * N do + Inc( N ); + PlayEnhMetaFile( Printer.Canvas.Handle, MF, + MakeRect( 0, 0, PageWidth-1, PageHeight-1 ) ); + + if I < ToPage then + Printer.NewPage; + end; + FINALLY + if PrintingStarted then + Printer.EndDoc; + END; +end; + +procedure TReport.ClearPages; +var I: Integer; +begin + for I := PageCount-1 downto 0 do + DeleteEnhMetaFile( Images[ I ] ); + FDCPages.Clear; + FHDPages.Clear; + FY := MarginsScreenPixels.Top; + FX := MarginsScreenPixels.Left; + FPagePixelsSize.cx := 0; // force recalculation of Page size +end; + +procedure TReport.SetMargins(const Value: TMargins); +begin + if (fMargins.Left = Value.Left) and + (fMargins.Top = Value.Top) and + (fMargins.Right = Value.Right) and + (fMargins.Bottom = Value.Bottom) then Exit; + if FPrinting then Abort; + FMargins := Value; +end; + +function TReport.GetMarginsPixels( const Index: Integer ): TMargins; +var DC: HDC; +begin + if Index = 1 then DC := Printer.Canvas.Handle + else DC := GetDC( 0 ); + Result.Left := Round( Margins.Left / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) ); + Result.Right := Round( Margins.Right / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) ); + Result.Top := Round( Margins.Top / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) ); + Result.Bottom := Round( Margins.Bottom / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) ); + if Index <> 1 then + ReleaseDC( 0, DC ); +end; + +{ TPreviewObj } + +procedure TPreviewObj.AdjustButtons( Sender: PObj ); +begin + TB.TBButtonEnabled[ TBFrst ] := FCurPage > 0; + TB.TBButtonEnabled[ TBPrev ] := FCurPage > 0; + TB.TBButtonEnabled[ TBNext ] := FCurPage < PageCount - 1; + TB.TBButtonEnabled[ TBLast ] := FCurPage < PageCount - 1; + TB.TBButtonEnabled[ TBPrnt ] := PageCount > 0; + {$IFDEF use_MHPRINTER} + TB.TBButtonEnabled[ TBExit ] := TRUE; + {$ENDIF} + if PageCount = 0 then + LB.Caption := '' + else + LB.Caption := 'Page ' + Int2Str( FCurPage + 1 ) + ' from ' + Int2Str( PageCount ); +end; + +procedure TPreviewObj.AdjustFitMode; +var K: Double; +begin + if PageCount = 0 then Exit; + case FFitMode of + 0: begin // fit Height + PB.Height := SB.ClientHeight; + K := FReport.PagePixelsSize.cx / FReport.PagePixelsSize.cy; + PB.Width := Round( K * SB.ClientHeight ); + SetScrollPos( SB.Handle, SB_VERT, 0, TRUE ); + end; + 1: begin // fit Width + PB.Width := SB.ClientWidth; + K := FReport.PagePixelsSize.cy / FReport.PagePixelsSize.cx; + PB.Height := Round( K * SB.ClientWidth ); + end; + 2: begin // 1:1 + PB.Width := FReport.PagePixelsSize.cx; + PB.Height := FReport.PagePixelsSize.cy; + end; + end; +end; + +destructor TPreviewObj.Destroy; +begin + FBuf.Free; + PSD.Free;{Brandys} + inherited; +end; + +function TPreviewObj.PageCount: Integer; +begin + Result := FReport.FDCPages.Count; +end; + +procedure TPreviewObj.PaintPage(Sender: PControl; DC: HDC); +var MF: HENHMETAFILE; + Tmp: PBitmap; + R: TRect; +begin + if FCurPage >= PageCount then Exit; + MF := FReport.Images[ FCurPage ]; + AdjustFitMode; + {if (PB.Width = FReport.PagePixelsSize.cx) and + (PB.Height = FReport.PagePixelsSize.cy) then + PlayEnhMetaFile( DC, MF, MakeRect( 0, 0, PB.Width, PB.Height ) ) + else} + begin + if (FBufPage <> FCurPage) or (FBuf = nil) or + (FBuf.Width <> PB.ClientWidth) or (FBuf.Height <> PB.ClientHeight) then + begin + FBuf.Free; + FBufPage := FCurPage; + FBuf := NewDIBBitmap( PB.ClientWidth, PB.ClientHeight, pf24bit ); + FBuf.Canvas.Brush.Color := clWhite; + FBuf.Canvas.FillRect( MakeRect( 0, 0, FBuf.Width, FBuf.Height ) ); + SetStretchBltMode( FBuf.Canvas.Handle, HALFTONE ); + SetBrushOrgEx( FBuf.Canvas.Handle, 0, 0, nil ); + {R := MakeRect( FReport.MarginsScreenPixels.Left, + FReport.MarginsScreenPixels.Top, + FBuf.Width-1 - FReport.MarginsScreenPixels.Right, + FBuf.Height-1 - FReport.MarginsScreenPixels.Bottom );} + R := MakeRect( 0, 0, FBuf.Width-1, FBuf.Height-1 ); + if FBuf.Width >= FReport.PagePixelsSize.cx then + PlayEnhMetaFile( FBuf.Canvas.Handle, MF, R ) + else + begin + Tmp := NewDIBBitmap( FReport.PagePixelsSize.cx, FReport.PagePixelsSize.cy, pf24bit ); + Tmp.Canvas.Brush.Color := clWhite; + Tmp.Canvas.FillRect( MakeRect( 0, 0, Tmp.Width, Tmp.Height ) ); + PlayEnhMetaFile( Tmp.Canvas.Handle, MF, MakeRect( 0, 0, Tmp.Width-1, Tmp.Height-1 ) ); + Inc( R.Right ); Inc( R.Bottom ); + Tmp.StretchDraw( FBuf.Canvas.Handle, R ); + Tmp.Free; + end; + end; + FBuf.Draw( DC, 0, 0 ); + end; +end; + +{$IFDEF use_MHPRINTER} +procedure TPreviewObj.PrinterSetup; +begin + ShowMessage( 'Not implementer.' ); +end; +{$ELSE} +procedure TPreviewObj.PrinterSetup; +var + Orientation: TPrinterOrientation; + PgSz: TSize; + M: TRect; +begin + Orientation := Printer.Orientation; + PgSz.cx := Printer.PageWidth; + PgSz.cy := Printer.PageHeight; + if not Assigned( FReport.OnPrint ) then + Options := Options - [ psdOrientation ]; + if PSD = nil then + PSD := NewPageSetupDialog( Form, Options ); + PSD.SetMargins( FReport.FMargins.Left, FReport.FMargins.Top, + FReport.FMargins.Right, FReport.FMargins.Bottom ); + if PSD.Execute then + begin + Printer.Assign(PSD.Info);//assign selected options to printer DC + M := PSD.GetMargins; + if Assigned( FReport.OnPrint ) then + if (Printer.Orientation <> Orientation) or + (Printer.PageWidth <> PgSz.cx) or + (Printer.PageHeight <> PgSz.cy) or + not CompareMem( @ M, @ FReport.FMargins, Sizeof( M ) ) then + begin + FReport.FMargins := M; + FCurPage := 0; + FReport.ClearPages; + PgSz.cx := GetDeviceCaps( Printer.Canvas.Handle, HORZSIZE ); + PgSz.cy := GetDeviceCaps( Printer.Canvas.Handle, VERTSIZE ); + FReport.CustomPaperSize := PgSz; + FReport.OnPrint( FReport ); + end; + Printer.AssignMargins(M,mgMillimeters); + end; +end; +{$ENDIF} + +procedure TPreviewObj.PrintAllPages; +begin + FReport.DoPrint; +end; + +procedure TPreviewObj.ResizePreviewForm(Sender: PObj); +begin + AdjustFitMode; +end; + +procedure TPreviewObj.SetCurPage(const Value: Integer); +begin + FCurPage := Value; + AdjustButtons( @ Self ); +end; + +procedure TPreviewObj.SetFitMode(const Value: Integer); +begin + if FFitMode = Value then Exit; + FFitMode := Value; + AdjustFitMode; + PB.Invalidate; +end; + +procedure TPreviewObj.TBClick(Sender: PObj); +begin + case PControl(Sender).CurIndex of + TBFrst: { << } FCurPage := 0; + TBPrev: { < } if FCurPage > 0 then Dec( FCurPage ); + TBNext: { > } if FCurPage < PageCount - 1 then Inc( FCurPage ); + TBLast: { >> } FCurPage := PageCount - 1; + TBPrnt: {Print} PrintAllPages; + TBSetu: {Setup} PrinterSetup; + TBView: {View} TBDropDownViewMenu( TB ); + TBExit: {Close} begin Form.Close; Exit; end; + end; + AdjustButtons( @ Self ); +end; + +procedure TPreviewObj.TBDropDownViewMenu(Sender: PObj); +var R: TRect; +begin + R := TB.TBButtonRect[ TBView ]; + R.Top := R.Bottom; + R.TopLeft := TB.Client2Screen( R.TopLeft ); + ViewMenu.RadioCheck( FitMode ); + ViewMenu.Popup( R.Left, R.Top ); +end; + +procedure TPreviewObj.TBViewMenuClick(Sender: PMenu; Item: Integer); +begin + FitMode := Item; +end; + +end. diff --git a/Addons/KOLSocket.pas b/Addons/KOLSocket.pas new file mode 100644 index 0000000..97a518d --- /dev/null +++ b/Addons/KOLSocket.pas @@ -0,0 +1,845 @@ +unit KOLSocket; + +interface + +uses + KOL, Windows, Messages, Winsock; + +const + WM_SOCKET = WM_USER + $7000; + WM_SOCKETERROR = WM_USER + $7001; + WM_SOCKETCLOSE = WM_USER + $7002; + WM_SOCKETREAD = WM_USER + $7003; + WM_SOCKETCONNECT = WM_USER + $7004; + WM_SOCKETACCEPT = WM_USER + $7005; + WM_SOCKETWRITE = WM_USER + $7006; + WM_SOCKETOOB = WM_USER + $7007; + WM_SOCKETLISTEN = WM_USER + $7008; + WM_SOCKETLOOKUP = WM_USER + $7009; + + EVENTS_DOLISTEN = FD_CLOSE OR FD_ACCEPT; + EVENTS_DOCONNECT = FD_CONNECT OR FD_CLOSE OR FD_READ; + EVENTS_SETSOCKETHANDLE = FD_READ OR FD_CLOSE OR FD_CONNECT; + + MaxWord = 65535; + MinWord = 0; + + c_FIRST = 1; + + INVALID_SOCKET = winsock.INVALID_SOCKET; + +type + + TWndMethod = procedure(var Message: TMessage) of object; + + PhWnd =^ThWnd; + ThWnd = object( TObj ) + protected + m_hWnd: hWnd; + destructor Destroy; virtual; + public + property Handle: hWnd read m_hWnd; + end; + + PAsyncSocket =^TAsyncSocket; + TKOLSocket = PAsyncSocket; + + TWMSocket = record + Msg: Word; + case Integer of + 0: ( + SocketWParam: Word; + SocketDataSize: LongInt; + SocketNumber: Longint; + SocketAddress: PAsyncSocket); + 1: ( + WParamLo: Byte; + WParamHi: Byte; + SocketEvent: Word; + SocketError: Word; + ResultLo: Word; + ResultHi: Word); + 2: ( + WParam: Word; + TaskHandle: Word; + WordHolder: Word; + pHostStruct: Pointer); + end; + + TBArray = array[0..65534] of byte; + + TBufRecord = record + i: integer; + p:^TBArray; + end; + + TSocketMessageEvent = procedure (SocketMessage: TWMSocket) of object; + + TAsyncSocket = object( TObj ) + m_SockAddr: TSockAddr; + m_Handle: TSocket; + m_hWnd: PhWnd; + fConnected: boolean; + fDNSResult: string; + fDNSHandle: integer; + FDnsBuffer: array [0..MAXGETHOSTSTRUCT] of char; + FList: PList; + FOnError: TSocketMessageEvent; + FOnLookup: TSocketMessageEvent; + FOnAccept: TSocketMessageEvent; + FOnClose: TSocketMessageEvent; + FOnConnect: TSocketMessageEvent; + FOnRead: TSocketMessageEvent; + FOnWrite: TSocketMessageEvent; + FOnListen: TSocketMessageEvent; + FOnOOB: TSocketMessageEvent; + + protected + destructor Destroy; virtual; + + private + function GetCount: LongInt; + function GetPortNumber: LongInt; + function GetIPAddress: String; + function ErrorTest(Evaluation: LongInt): LongInt; + + procedure AllocateSocket; + procedure KillWinsockBug; + procedure SetPortNumber(NewPortNumber: LongInt); + procedure SetIPAddress(NewIPAddress: String); + procedure SetSocketHandle(NewSocketHandle: TSocket); + function GetConnected: boolean; + + // Message Handlers + + procedure HWndProcedure(var Message: TMessage); + + procedure Message_Error(var Message: TWMSocket); + procedure Message_Lookup(var Message: TWMSocket); + procedure Message_Close(var Message: TWMSocket); + procedure Message_Accept(var Message: TWMSocket); + procedure Message_Read(var Message: TWMSocket); + procedure Message_Connect(var Message: TWMSocket); + procedure Message_Write(var Message: TWMSocket); + procedure Message_OOB(var Message: TWMSocket); + procedure Message_Listen(var Message: TWMSocket); + procedure DoReceive(Buffer: Pointer; var ReceiveLen: LongInt); + procedure DoFinal(Abort: boolean); + + public + procedure ProcessMessages; + function DoGetHostByAddr(IPAddr: PChar): String; + function DoGetHostByName(Name: PChar): String; + + procedure DoLookup(host: string); + procedure DoClose; + procedure DoSend(Buffer: Pointer; var SendLen: LongInt); + procedure DoListen; + procedure DoConnect; + procedure DoAccept(var AcceptSocket: PAsyncSocket); + + procedure SendString(fString: String); + + function ReadData(b: pointer; c: integer): integer; + function ReadLine(c: char): string; overload; + function ReadLine(c: char; t: integer): string; overload; + function ErrToStr(Err: LongInt): String; + function LocalIP: String; + function LocalPort: integer; + + property SocketHandle: TSocket read m_Handle write SetSocketHandle; + property IPAddress: String read GetIPAddress write SetIPAddress; + property PortNumber: LongInt read GetPortNumber write SetPortNumber; + property Count: LongInt read GetCount; + property Connected: boolean read GetConnected; + property DNSResult: string read fDNSResult write fDNSResult; + + property OnError: TSocketMessageEvent read FOnError write FOnError; + property OnLookup: TSocketMessageEvent read FOnLookup write FOnLookup; + property OnAccept: TSocketMessageEvent read FOnAccept write FOnAccept; + property OnClose: TSocketMessageEvent read FOnClose write FOnClose; + property OnConnect: TSocketMessageEvent read FOnConnect write FOnConnect; + property OnRead: TSocketMessageEvent read FOnRead write FOnRead; + property OnWrite: TSocketMessageEvent read FOnWrite write FOnWrite; + property OnOOB: TSocketMessageEvent read FOnOOB write FOnOOB; + property OnListen: TSocketMessageEvent read FOnListen write FOnListen; + end; + + function NewThWnd(WndMethod: TWndMethod): PhWnd; + function NewAsyncSocket: PAsyncSocket; + +var + InstanceCount: LongInt = 0; + +implementation + +uses objects; + +function NewThWnd; +begin + New(Result, Create); + Result.m_hWnd := AllocateHWnd(WndMethod); +end; // constructor ThWnd.Create(WndMethod: TWndMethod) + +destructor ThWnd.Destroy; +begin + DeallocateHWnd(m_hWnd); + inherited; +end; + +function NewAsyncSocket; +var + TempWSAData: TWSAData; +begin + InstanceCount := InstanceCount + 1; + New(Result, Create); + if (InstanceCount = c_FIRST) then + Result.ErrorTest(WSAStartup($101, TempWSAData)); + Result.KillWinsockBug; + Result.m_Handle := INVALID_SOCKET; + Result.m_SockAddr.sin_family := AF_INET; + Result.m_SockAddr.sin_addr.s_addr := INet_Addr('0.0.0.0'); + Result.PortNumber := 0; + Result.FList := NewList; + Result.m_hWnd := NewThWnd(Result.HWndProcedure); +end; // constructor TAsyncSocket.Create + +function TAsyncSocket.GetCount; +var i: integer; + t:^TBufRecord; +begin + result := 0; + for i := 0 to FList.Count - 1 do begin + t := FList.Items[i]; + result := result + t^.i; + end; +end; + +function TAsyncSocket.ReadData; +var n, + r: integer; + t:^TBufRecord; + u:^TBufRecord; + a:^TBArray; +begin + if FList.count = 0 then begin + result := 0; + exit; + end; + n := 0; + a := b; + while (n < c) and (n < count) do begin + r := c - n; + t := FList.Items[0]; + if r > t^.i then r := t^.i; + move(t^.p^, a^[n], r); + n := n + r; + if r = t^.i then begin + FreeMem(t^.p, t^.i); + FreeMem(t, SizeOf(TBufRecord)); + FList.Delete(0); + end else begin + GetMem(u, SizeOf(TBufRecord)); + u^.i := t^.i - r; + GetMem(u^.p, u^.i); + move(t^.p^[r], u^.p^, u^.i); + FreeMem(t^.p, t^.i); + FreeMem(t, SizeOf(TBufRecord)); + FList.Items[0] := u; + end; + end; + result := n; +end; + +function TAsyncSocket.ReadLine(c: char): string; +var i, + n, + j: integer; + t:^TBufRecord; + s: string; +begin + result := ''; + n := 0; + if count = 0 then exit; + for i := 0 to FList.Count - 1 do begin + t := FList.Items[i]; + for j := 0 to t^.i - 1 do begin + inc(n); + if chr(t^.p^[j]) = c then begin + if n > 1 then begin + setlength(s, n - 1); + ReadData(@s[1], n - 1); + ReadData(@n , 1); + result := s; + end else begin + ReadData(@n , 1); + result := ''; + end; + exit; + end; + end; + end; +end; + +function TAsyncSocket.ReadLine(c: char; t: integer): string; +var tt: longint; + Msg: tagMSG; +begin + result := ''; + tt := gettickcount; + while (result = '') and (longint(gettickcount) < tt + t * 1000) do begin + if PeekMessage(Msg, m_hWnd.m_hWnd, 0, 0, PM_REMOVE) then begin + DispatchMessage(Msg); + end; + result := ReadLine(c); + if m_Handle = INVALID_SOCKET then exit; + end; +end; + +function TAsyncSocket.GetIPAddress: String; +begin + Result := INet_NToA(m_SockAddr.sin_addr); +end; // function TAsyncSocket.GetIPAddress: String + +function TAsyncSocket.GetPortNumber: LongInt; +begin + Result := NToHS(m_SockAddr.sin_port); +end; // function TAsyncSocket.GetPortNumber: Word + +procedure TAsyncSocket.AllocateSocket; +begin + if (m_Handle = INVALID_SOCKET) then + begin + m_Handle := ErrorTest(socket(AF_INET, SOCK_STREAM, 0)); + end; // if (m_Handle = INVALID_SOCKET) then +end; // procedure TAsyncSocket.AllocateSocket + +procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket); +begin + DoFinal(True); + m_Handle := NewSocketHandle; + ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_SETSOCKETHANDLE)); +end; // procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket) + +function TAsyncSocket.GetConnected; +begin + result := fConnected; +end; + +function TAsyncSocket.ErrorTest(Evaluation: LongInt): LongInt; +var + TempMessage: TWMSocket; +begin + if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then + begin + TempMessage.Msg := WM_SOCKETERROR; + TempMessage.SocketError := WSAGetLastError; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Error(TempMessage); + Result := Evaluation; + end // if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then + else + Result := Evaluation; +end; // function ErrorTest(Evaluation: LongInt): LongInt; + +procedure TAsyncSocket.KillWinsockBug; +var + Addr: Integer; +begin + Addr := 0; + // For an unknown reason, if a call is made to GetHostByName and it should + // fail, the following call to GetHostByAddr will not fail, but return '>' + // in the place of the host name. This clears the problem up. + GetHostByName(''); + GetHostByAddr(@Addr, SizeOf(Integer), PF_INET); + GetHostByName(''); +end; + +procedure TAsyncSocket.SetIPAddress(NewIPAddress: String); +var + pTempHostEnt: PHostEnt; +begin + m_SockAddr.sin_addr.s_addr := INet_Addr(PChar(NewIPAddress)); + if (m_SockAddr.sin_addr.s_addr = u_long(INADDR_NONE)) then + begin + pTempHostEnt := GetHostByName(PChar(NewIPAddress)); + if (pTempHostEnt <> Nil) then + m_SockAddr.sin_addr.s_addr := PInAddr(pTempHostEnt^.h_addr_list^)^.s_addr; + end; +end; // procedure TAsyncSocket.SetIPAddress(NewIPAddress: String) + +procedure TAsyncSocket.SetPortNumber(NewPortNumber: LongInt); +begin + if ((NewPortNumber > 0) AND (NewPortNumber <= MaxWord)) then + m_SockAddr.sin_port := HToNS(NewPortNumber); +end; // procedure TAsyncSocket.SetPortNumber(NewPortNumber: Word) + +procedure TAsyncSocket.DoReceive(Buffer: Pointer; var ReceiveLen: LongInt); +begin + ReceiveLen := recv(m_Handle, Buffer^, ReceiveLen, 0); + ErrorTest(ReceiveLen); +end; // TAsyncSocket.DoReceive(Buffer: Pointer; BufferLen: LongInt) + +procedure TAsyncSocket.DoSend(Buffer: Pointer; var SendLen: LongInt); +begin + SendLen := send(m_Handle, Buffer^, SendLen, 0); + ErrorTest(SendLen); +end; // procedure TAsyncSocket.DoSend(Buffer: Pointer; BufferLen: LongInt) + +procedure TAsyncSocket.DoLookup; +var + IPAddr : TInAddr; +begin + if Host = '' then begin + Exit; + end; + + { Cancel any pending lookup } + if FDnsHandle <> 0 then + WSACancelAsyncRequest(FDnsHandle); + + FDnsResult := ''; + + IPAddr.S_addr := Inet_addr(PChar(Host)); + if IPAddr.S_addr <> u_long(INADDR_NONE) then begin + FDnsResult := inet_ntoa(IPAddr); +{ TriggerDnsLookupDone(0);} + Exit; + end; + + FDnsHandle := WSAAsyncGetHostByName(m_hWnd.Handle, + WM_SOCKETLOOKUP, + @Host[1], + @FDnsBuffer, + SizeOf(FDnsBuffer)); + if FDnsHandle = 0 then begin + ErrorTest(WSAGetLastError); + Exit; + end; +end; + +procedure TAsyncSocket.DoClose; +begin + DoFinal(True); +end; + +procedure TAsyncSocket.DoFinal; +var + TempMessage: TWMSocket; +begin + if (m_Handle <> INVALID_SOCKET) then begin + if not Abort then begin + ProcessMessages; + end; + TempMessage.Msg := WM_SOCKETCLOSE; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Close(TempMessage); + ErrorTest(closesocket(m_Handle)); + m_Handle := INVALID_SOCKET; + end; +end; + +procedure TAsyncSocket.DoAccept(var AcceptSocket: PAsyncSocket); +var + TempSize: Integer; + TempSock: TSocket; + TempAddr: TSockAddrIn; +begin + TempSize := SizeOf(TSockAddr); + TempSock := accept(m_Handle, @TempAddr, @TempSize); + AcceptSocket.m_SockAddr := TempAddr; + if (ErrorTest(TempSock) <> INVALID_SOCKET) then + AcceptSocket.SocketHandle := TempSock; +end; // procedure TAsyncSocket.DoAccept(var AcceptSocket: TAsyncSocket) + +procedure TAsyncSocket.DoListen; +var + TempMessage: TWMSocket; +begin + DoClose; + AllocateSocket; + if + (ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOLISTEN)) + <> SOCKET_ERROR) AND + (ErrorTest(bind(m_Handle, m_SockAddr, SizeOf(TSockAddr))) <> SOCKET_ERROR) AND + (ErrorTest(listen(m_Handle, 5)) <> SOCKET_ERROR) then + begin + TempMessage.Msg := WM_SOCKETLISTEN; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Listen(TempMessage); + end + else + DoClose; +end; // procedure TAsyncSocket.DoListen + +procedure TAsyncSocket.DoConnect; +var + TempResult: LongInt; +begin + DoClose; + AllocateSocket; + ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOCONNECT)); + TempResult := connect(m_Handle, m_SockAddr, SizeOf(TSockAddr)); + if ((TempResult = SOCKET_ERROR) AND (WSAGetLastError <> WSAEWOULDBLOCK)) then + ErrorTest(SOCKET_ERROR); +end; // procedure TAsyncSocket.DoConnect + +procedure TAsyncSocket.SendString; +var + L: LongInt; +begin + L := Length(fString); + DoSend(PChar(fString), L); +end; + +function TAsyncSocket.DoGetHostByName(Name: PChar): String; +var + pTempHostEnt: PHostEnt; +begin + pTempHostEnt := GetHostByName(Name); + if (pTempHostEnt <> Nil) then + Result := inet_ntoa(pInAddr(pTempHostEnt^.h_addr_list^)^) + else + Result := ''; +end; + +procedure TAsyncSocket.ProcessMessages; +var Msg: TMsg; +begin + while PeekMessage(Msg, m_hWnd.m_hWnd, WM_SOCKET, WM_SOCKETLOOKUP, PM_REMOVE) do begin + DispatchMessage(Msg); + end; +end; + +function TAsyncSocket.DoGetHostByAddr(IPAddr: PChar): String; +var + pTempHostEnt: PHostEnt; + TempAddr: LongInt; +begin + TempAddr := INet_Addr(IPAddr); + pTempHostEnt := GetHostByAddr(@TempAddr, SizeOf(TempAddr), PF_INET); + if (pTempHostEnt <> Nil) then + Result := pTempHostEnt^.h_name + else + Result := ''; +end; + +procedure TAsyncSocket.HWndProcedure(var Message: TMessage); +var + TempMessage: TWMSocket; +begin + case Message.Msg of + WM_SOCKETLOOKUP: + begin + TempMessage.Msg := WM_SOCKETLOOKUP; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Lookup(TempMessage); + end; + WM_SOCKET: + begin + if (Message.LParamHi > WSABASEERR) then + begin + WSASetLastError(Message.LParamHi); + ErrorTest(SOCKET_ERROR); + end // if (Message.LParamHi > WSABASEERR) then + else + begin + case Message.LParamLo of + FD_READ: + begin + TempMessage.SocketDataSize := 0; + ErrorTest(IOCtlSocket(m_Handle, FIONREAD, TempMessage.SocketDataSize)); + TempMessage.Msg := WM_SOCKETREAD; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Read(TempMessage); + end; // FD_READ + FD_CLOSE: + begin + DoFinal(False); + end; // FD_CLOSE + FD_CONNECT: + begin + TempMessage.Msg := WM_SOCKETCONNECT; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Connect(TempMessage); + end; // FD_CONNECT + FD_ACCEPT: + begin + TempMessage.Msg := WM_SOCKETACCEPT; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Accept(TempMessage); + end; // FD_ACCEPT + FD_WRITE: + begin + TempMessage.Msg := WM_SOCKETWRITE; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_Write(TempMessage); + end; // FD_WRITE + FD_OOB: + begin + TempMessage.Msg := WM_SOCKETOOB; + TempMessage.SocketNumber := m_Handle; + TempMessage.SocketAddress := @self; + Message_OOB(TempMessage); + end; // FD_OOB + end; // case Message.LParamLo of + end // else (if (Message.LParamHi > WSABASEERR) then) + end; // WM_SOCKET: + else + Message.Result := DefWindowProc(m_hWnd.m_hWnd, Message.Msg, Message.WParam, Message.LParam); + end; // case Message.Msg of +end; // procedure TAsyncSocket.HWndProcedure(var Message: TMessage) + +procedure TAsyncSocket.Message_Error(var Message: TWMSocket); +begin + if Assigned(FOnError) then FOnError(Message) + else + MessageBox(HWND_DESKTOP, PChar(ErrToStr(Message.SocketError) + ' on socket ' + + Int2Str(Message.SocketNumber)), 'Message_Error', MB_OK); +end; // procedure TAsyncSocket.Message_Error(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Lookup(var Message: TWMSocket); +var p: PHostEnt; +begin + p := @fDNSBuffer; + fDNSResult := p.h_name; + if Assigned(FOnLookup) then FOnLookup(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLOOKUP on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Lookup', MB_OK); +end; // procedure TAsyncSocket.Message_LookUp(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Close(var Message: TWMSocket); +begin + fConnected := False; + if Assigned(FOnClose) then FOnClose(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCLOSE on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Close', MB_OK); +end; // procedure TAsyncSocket.Message_Close(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Accept(var Message: TWMSocket); +begin + fConnected := True; + if Assigned(FOnAccept) then FOnAccept(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETACCEPT on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Accept', MB_OK); +end; // procedure TAsyncSocket.Message_Accept(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Read(var Message: TWMSocket); +var t:^TBufRecord; +begin + if Message.SocketDataSize > 0 then begin + fConnected := True; + GetMem(t, sizeof(TBufRecord)); + t^.i := Message.SocketDataSize; + GetMem(t^.p, t^.i); + DoReceive(t^.p, t^.i); + FList.Add(t); + end; + if Assigned(FOnRead) then FOnRead(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETREAD on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Read', MB_OK); +end; // procedure TAsyncSocket.Message_Read(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Connect(var Message: TWMSocket); +begin + fConnected := True; + if Assigned(FOnConnect) then FOnConnect(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCONNECT on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Connect', MB_OK); +end; // procedure TAsyncSocket.Message_Connect(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Write(var Message: TWMSocket); +begin + fConnected := True; + if Assigned(FOnWrite) then FOnWrite(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETWRITE on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Write', MB_OK); +end; // procedure TAsyncSocket.Message_Write(var Message: TWMSocket) + +procedure TAsyncSocket.Message_OOB(var Message: TWMSocket); +begin + if Assigned(FOnOOB) then FOnOOB(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETOOB on socket ' + Int2Str(Message.SocketNumber)), + 'Message_OOB', MB_OK); +end; // procedure TAsyncSocket.Message_OOB(var Message: TWMSocket) + +procedure TAsyncSocket.Message_Listen(var Message: TWMSocket); +begin + if Assigned(FOnListen) then FOnListen(Message) + else + MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLISTEN on socket ' + Int2Str(Message.SocketNumber)), + 'Message_Listen', MB_OK); +end; // procedure TAsyncSocket.Message_Listen(var Message: TWMSocket) + +destructor TAsyncSocket.Destroy; +var t:^TBufRecord; + i: integer; +begin + DoClose; + if (InstanceCount = c_FIRST) then + ErrorTest(WSACleanup); + m_hWnd.Free; + for i := 0 to FList.Count - 1 do begin + t := FList.Items[i]; + FreeMem(t^.p, t^.i); + FreeMem(t, SizeOf(TBufRecord)); + end; + FList.Free; + InstanceCount := InstanceCount - 1; + inherited; +end; + +function TAsyncSocket.ErrToStr(Err: LongInt): String; +begin + case Err of + WSAEINTR: + Result := 'WSAEINTR'; + WSAEBADF: + Result := 'WSAEBADF'; + WSAEACCES: + Result := 'WSAEACCES'; + WSAEFAULT: + Result := 'WSAEFAULT'; + WSAEINVAL: + Result := 'WSAEINVAL'; + WSAEMFILE: + Result := 'WSAEMFILE'; + WSAEWOULDBLOCK: + Result := 'WSAEWOULDBLOCK'; + WSAEINPROGRESS: + Result := 'WSAEINPROGRESS'; + WSAEALREADY: + Result := 'WSAEALREADY'; + WSAENOTSOCK: + Result := 'WSAENOTSOCK'; + WSAEDESTADDRREQ: + Result := 'WSAEDESTADDRREQ'; + WSAEMSGSIZE: + Result := 'WSAEMSGSIZE'; + WSAEPROTOTYPE: + Result := 'WSAEPROTOTYPE'; + WSAENOPROTOOPT: + Result := 'WSAENOPROTOOPT'; + WSAEPROTONOSUPPORT: + Result := 'WSAEPROTONOSUPPORT'; + WSAESOCKTNOSUPPORT: + Result := 'WSAESOCKTNOSUPPORT'; + WSAEOPNOTSUPP: + Result := 'WSAEOPNOTSUPP'; + WSAEPFNOSUPPORT: + Result := 'WSAEPFNOSUPPORT'; + WSAEAFNOSUPPORT: + Result := 'WSAEAFNOSUPPORT'; + WSAEADDRINUSE: + Result := 'WSAEADDRINUSE'; + WSAEADDRNOTAVAIL: + Result := 'WSAEADDRNOTAVAIL'; + WSAENETDOWN: + Result := 'WSAENETDOWN'; + WSAENETUNREACH: + Result := 'WSAENETUNREACH'; + WSAENETRESET: + Result := 'WSAENETRESET'; + WSAECONNABORTED: + Result := 'WSAECONNABORTED'; + WSAECONNRESET: + Result := 'WSAECONNRESET'; + WSAENOBUFS: + Result := 'WSAENOBUFS'; + WSAEISCONN: + Result := 'WSAEISCONN'; + WSAENOTCONN: + Result := 'WSAENOTCONN'; + WSAESHUTDOWN: + Result := 'WSAESHUTDOWN'; + WSAETOOMANYREFS: + Result := 'WSAETOOMANYREFS'; + WSAETIMEDOUT: + Result := 'WSAETIMEDOUT'; + WSAECONNREFUSED: + Result := 'WSAECONNREFUSED'; + WSAELOOP: + Result := 'WSAELOOP'; + WSAENAMETOOLONG: + Result := 'WSAENAMETOOLONG'; + WSAEHOSTDOWN: + Result := 'WSAEHOSTDOWN'; + WSAEHOSTUNREACH: + Result := 'WSAEHOSTUNREACH'; + WSAENOTEMPTY: + Result := 'WSAENOTEMPTY'; + WSAEPROCLIM: + Result := 'WSAEPROCLIM'; + WSAEUSERS: + Result := 'WSAEUSERS'; + WSAEDQUOT: + Result := 'WSAEDQUOT'; + WSAESTALE: + Result := 'WSAESTALE'; + WSAEREMOTE: + Result := 'WSAEREMOTE'; + WSASYSNOTREADY: + Result := 'WSASYSNOTREADY'; + WSAVERNOTSUPPORTED: + Result := 'WSAVERNOTSUPPORTED'; + WSANOTINITIALISED: + Result := 'WSANOTINITIALISED'; + WSAHOST_NOT_FOUND: + Result := 'WSAHOST_NOT_FOUND'; + WSATRY_AGAIN: + Result := 'WSATRY_AGAIN'; + WSANO_RECOVERY: + Result := 'WSANO_RECOVERY'; + WSANO_DATA: + Result := 'WSANO_DATA'; + else Result := 'UNDEFINED WINSOCK ERROR'; + end; // case Err of +end; // function TAsyncSocket.ErrToStr(Err: LongInt): String + +function TAsyncSocket.LocalIP; +var Name: TSockAddrIn; + len: integer; +begin + GetSockName(m_Handle, Name, len); + Result := int2str(ord(Name.sin_addr.S_un_b.s_b1)) + '.' + + int2str(ord(Name.sin_addr.S_un_b.s_b2)) + '.' + + int2str(ord(Name.sin_addr.S_un_b.s_b3)) + '.' + + int2str(ord(Name.sin_addr.S_un_b.s_b4)); +end; + +function TAsyncSocket.LocalPort; +var Name: TSockAddrIn; + len: integer; + err: integer; + Tmp: TWMSocket; +begin + Result := 0; + err := GetSockName(m_Handle, Name, len); + if err = 0 then begin + Result := NToHS(Name.sin_port); + end else begin + Tmp.Msg := WM_SOCKETERROR; + Tmp.SocketError := WSAGetLastError; + Tmp.SocketNumber := m_Handle; + Tmp.SocketAddress := @self; + Message_Error(Tmp); + end; +end; + +end. + diff --git a/Addons/KOLmdvDBF.pas b/Addons/KOLmdvDBF.pas new file mode 100644 index 0000000..6de3076 --- /dev/null +++ b/Addons/KOLmdvDBF.pas @@ -0,0 +1,1292 @@ +unit KOLmdvDBF; +// Компонент mdvDBF - прямой доступ к DBF-файлам (с memo) без использования дополнительного ПО. +// E-Mail: dominiko-m@yandex.ru +// http://www.mdvkol.narod.ru/ +// Автор: Матвеев Дмитрий + +// - История - + +// Дата: 01.03.2007 Версия: 1.03 +{ +[+] - добавил метод NewDbf +[*] - Поправил сигнатуру мемо-полей для dBaseIV +} + +// Дата: 26.09.2005 Версия: 1.02 +{ +[+] - добавил несколько вспомогательных методов +} +// Дата: 07.12.2004 Версия: 1.01 +{ +[+] - добавил сигнатуру мемо-полей +} + +// Дата: 02.12.2004 Версия: 1.00 + {Стартовая версия} + + +interface + +uses Windows, KOL; + +const + DBF_FoxBASE = $02; + DBF_FoxBASE_ = $FB; + DBF_dBaseIIIplus = $03; + DBF_dBaseIIIplusMemo = $83; + DBF_dBaseIV = $04; + DBF_dBaseIVSQLtable = $43; + DBF_dBaseIVSQLsystem = $63; + DBF_dBaseIVSQLtableMemo = $CB; + DBF_dBaseIVMemo = $8B; + DBF_dBaseV = $05; + DBF_FoxPro2xMemo = $F5; + DBF_VisualFoxPro = $30; + DBF_VisualFoxProInc = $31; + + MsDos_US_437 = $01; + MsDos_Mazovia_Polish_620 = $69; + MsDos_Greek_737 = $6A; + MsDos_International_850 = $02; + MsDos_Eastern_European_852 = $64; + MsDos_Turkish_857 = $6B; + MsDos_Icelandic_861 = $67; + MsDos_Nordic_865 = $66; + MsDos_Russian_866 = $65; + MsDos_Kamenicky_Czech_895 = $68; + Windows_Thai_874 = $7C; + Windows_Japanese_932 = $7B; + Windows_Chinese_PRC_Singapore_936 = $7A; + Windows_Korean_949 = $79; + Windows_Chinese_HongKongSAR_Taiwan_950 = $78; + Windows_Eastern_European_1250 = $C8; + Windows_Russian_1251 = $C9; + Windows_ANSI_1252 = $03; + Windows_Greek_1253 = $CB; + Windows_Turkish_1254 = $CA; + Windows_Hebrew_1255 = $7D; + Windows_Arabic_1256 = $7E; + Windows_Standard_Macintosh_10000 = $04; + Windows_Greek_Macintosh_10006 = $98; + Windows_Russian_Macintosh_10007 = $96; + Windows_Macintosh_EE_10029 = $97; + +type + TYYMMDD = array [1..3] of Byte; + TDBFHeader = packed record + DBFType: Byte; // Тип файла (DBF_xxx) + LastUpdated: TYYMMDD; // Дата последнего обновления в формате YYMMDD + RecordCount: DWord; // Количество записей в таблице + HeaderLength: Word; // Количество байт, занимаемых заголовком + RecordLength: Word; // Количество байт, занимаемых записью + Reserved_1: array [1..16] of Byte; // 3-Зарезервированная область; 13 - Зарезервировано для сетевой версии dBASE III PLUS + TableFlags: Byte; // $01 - file has a structural .cdx; $02 - file has a Memo field; $04 - file is a database (.dbc). This byte can contain the sum of any of the above values. For example, the value 0x03 indicates the table has a structural .cdx and a Memo field. + CodePage: Byte; // Кодовая страница + Reserved_2: Word; // Зарезервированная область + end; + + TFieldName = array [1..11] of Char; + TDBFField = packed record + FieldName: TFieldName; // Название поля + FieldType: Char; // Тип поля (C – Character; Y – Currency; N – Numeric; F – Float; D – Date; T – DateTime; B – Double; I – Integer; L – Logical; M – Memo; G – General; C – Character (binary); M – Memo (binary); P – Picture; + Address: DWord; // Адрес поля в записи + FieldLength: Byte; // Длина поля (в байтах) + Decimals: Byte; // Длина десятичной части + FieldFlags: Byte; // Флаг поля ($01 - System Column (not visible to user); $02 - Column can store null values; $04 - Binary column (for CHAR and MEMO only); $06($02+$04) - When a field is NULL and binary (Integer, Currency, and Character/Memo fields); $0C - Column is autoincrementing; + AutoIncNext: DWord; // Следующее значение для Автоинкримента + AutoIncStep: Byte; // Шаг Автоинкримента + Reserved3 : array[1..7] of Byte; // Зарезервированная область + IndexFlag : Byte; // Флаг MDX-поля: $01 если поле имеет метку индекса в MDX-файле, $00 - нет. + end; + + TFPTHeader = packed record + NextFree: DWord; // * Location of next free block + Unused: Word; // Unused + BlockSize: Word; // * Block size (bytes per block) + Unused_2: array [0..503] of Byte; + end; + + TDBTHeader = packed record + NextFree: DWord; // Location of next free block + Reserved1: DWord; + DbfFileName: array [1..9] of Char; // Name parent DBF table + reserved2: array [1..3] of Char; + BlockSize: Word; + end; + + TMemoBlockHeader = packed record + BlockSignature: DWord; // * Block signature (indicates the type of data in the block) (0 – picture (picture field type); 1 – text (memo field type)) + Length: DWord; // * Length of memo (in bytes) + //08–n Memo text (n = length) + end; + + PRecordBuffer = ^TRecordBuffer; + TRecordBuffer = array[0..0] of Byte; + + PDBFFields = ^TDBFFields; + TDBFFields = array [0..0] of TDBFField; + + TFieldType = (ftUnknown, ftCharacter, ftCurrency, ftNumeric, + ftFloat, ftDate, ftDateTime, ftBinary, + ftInteger, ftLogical, ftMemo, ftGeneral, + ftCharacterBin, ftMemoBin, ftPicture); + + TDbfErrors = (eNoErrors, eUnknownError, eFileNotExist, eFileOpen, eDBFHeader, eAppendRecord, eReadRecord, eWriteRecord, eReadField, eWriteField, eInvalidValue); + + TOnDbfEvent = procedure(Sender: PObj; var Allowed: Boolean) of object; + + TMemoType = (mtUnknown, mtFoxPro, mtdBaseIV, mtdBase); + + PmdvDBF = ^TmdvDBF; + TKOLmdvDBF = PmdvDBF; + + TmdvDBF = object(TObj) + private + FDBFHeader: TDBFHeader; + FDBFFields: PDBFFields; + FRecordBuffer: PRecordBuffer; + FFieldsCount: Integer; + FFPTHeader: TFPTHeader; + FDBTHeader: TDBTHeader; + + FHasMemo: Boolean; + FActive, FAutoUpdate, FReadOnly, FDBFModified, FRecordModified: Boolean; + FFileName: String; + FFileNameMemo: String; + FDBFStream, FDBFMemoStream: PStream; + FCurrentRecord: DWord; + FBOF, FEOF: Boolean; + FError: TDbfErrors; + FOnScroll, FOnDelete, FOnAppend: TOnDbfEvent; + + function InvertDWord(var Value: DWord): DWord; + + function ReadFields: Boolean; + procedure ReadRecord; + procedure WriteRecord; + procedure SetDate(var ADate: TYYMMDD); + + function GetLastUpdated: TDateTime; + function GetHasMemo: Boolean; + + function GetMemoInfo(Index: Integer; var ABlockNum, ABlockSize, ABlockCount, ASize: DWord): TMemoType; + + procedure SetActive(const Value: Boolean); + procedure SetFileName(const Value: String); + function GetError: TDbfErrors; + + function GetFieldName(Index: Integer): String; + function GetFieldNumber(NameField: String): Integer; + function GetFieldType(Index: Integer): TFieldType; + function GetFieldDecimals(Index: Integer): Byte; + function GetFieldLength(Index: Integer): Byte; + procedure SetCurrentRecord(const Value: DWord); + + function GetIsDelete: Boolean; + procedure SetIsDelete(const Value: Boolean); + + function GetFieldIsString(Index: Integer): Boolean; + function GetFieldIsBoolean(Index: Integer): Boolean; + function GetFieldIsDateTime(Index: Integer): Boolean; + function GetFieldIsFloat(Index: Integer): Boolean; + function GetFieldIsInteger(Index: Integer): Boolean; + + function GetAsText(Index: Integer): String; + function GetAsString(Index: Integer): String; + function GetAsBoolean(Index: Integer): Boolean; + function GetAsDateTime(Index: Integer): TDateTime; + function GetAsFloat(Index: Integer): Double; + function GetAsInteger(Index: Integer): Integer; + + procedure SetString(Index: Integer; Value: String); + procedure SetAsText(Index: Integer; Value: String); + procedure SetAsString(Index: Integer; const Value: String); + procedure SetAsBoolean(Index: Integer; const Value: Boolean); + procedure SetAsDateTime(Index: Integer; const Value: TDateTime); + procedure SetAsFloat(Index: Integer; const Value: Double); + procedure SetAsInteger(Index: Integer; const Value: Integer); + + function GetFieldIsNull(Index: Integer): Boolean; + function GetFieldIsMemo(Index: Integer): Boolean; + function GetMemoAsString(Index: Integer): String; + procedure SetMemoAsString(Index: Integer; Value: String); + + function GetAsBooleanByName(AFieldName: String): Boolean; + function GetAsDateTimeByName(AFieldName: String): TDateTime; + function GetAsFloatByName(AFieldName: String): Double; + function GetAsIntegerByName(AFieldName: String): Integer; + function GetAsStringByName(AFieldName: String): String; + function GetAsTextByName(AFieldName: String): String; + procedure SetAsBooleanByName(AFieldName: String; const Value: Boolean); + procedure SetAsDateTimeByName(AFieldName: String; const Value: TDateTime); + procedure SetAsFloatByName(AFieldName: String; const Value: Double); + procedure SetAsIntegerByName(AFieldName: String; const Value: Integer); + procedure SetAsStringByName(AFieldName: String; const Value: String); + procedure SetAsTextByName(AFieldName: String; const Value: String); + function GetMemoAsStringByName(AFieldName: String): String; + procedure SetMemoAsStringByName(AFieldName: String; const Value: String); + + public + destructor Destroy; virtual; + + property DBFType: Byte read FDBFHeader.DBFType; // Тип файла (DBF_xxx) + property LastUpdated: TDateTime read GetLastUpdated; // Дата последнего обновления + property RecordLength: Word read FDBFHeader.RecordLength; // Количество байтов, занимаемых записью + property HasMemo: Boolean read GetHasMemo; + property CodePage: Byte read FDBFHeader.CodePage; + + property FieldsCount: Integer read FFieldsCount; + property FieldName[Index: Integer]: String read GetFieldName; + property FieldNumber[NameField: String]: Integer read GetFieldNumber; + property FieldType[Index: Integer]: TFieldType read GetFieldType; + property FieldLength[Index: Integer]: Byte read GetFieldLength; + property FieldDecimals[Index: Integer]: Byte read GetFieldDecimals; + + property RecordCount: DWord read FDBFHeader.RecordCount; // Количество записей в таблице + property CurrentRecord: DWord read FCurrentRecord write SetCurrentRecord; + property BOF: Boolean read FBOF; + property EOF: Boolean read FEOF; + procedure First; + procedure Last; + procedure Next; + procedure Prev; + function Locate(AFieldName, AValue: String): Boolean; overload; + function Locate(AFieldNames, AValues: array of String): Boolean; overload; + function MaxOfField(AFieldName: String): Integer; + + procedure Append; + procedure Post; + property IsDelete: Boolean read GetIsDelete write SetIsDelete; + procedure RefreshRecord; + procedure PackDBF; + { DescriptionDBF format: + #2#1 + #2#2#2#1 + #2#2#2#1 + ... + #2#2#2#1 + + + BlockSize: recommend values 64, 128, 256, 512, 1024, 2048; + FieldName: max length: 10 + FieldType: 'C' - Character; 'N' - Numeric; 'D' - Date; 'B' - Binary; 'L' - Logical, 'M' - Memo + FieldLength: 'C' - 1..254; 'N' - 1..20; 'D' - 8; 'L' - 1; 'M' - 10; 'B' - 10 + Decimals: 'C' - 0; 'N' - 0..FieldLength-1; 'D' - 0; 'L' - 0; 'M' - 0; 'B' - 0 + + } + function NewDbf(AFileName: String; DescriptionDBF: String): Boolean; + + property FieldIsString[Index: Integer]: Boolean read GetFieldIsString; + property FieldIsInteger[Index: Integer]: Boolean read GetFieldIsInteger; + property FieldIsFloat[Index: Integer]: Boolean read GetFieldIsFloat; + property FieldIsDateTime[Index: Integer]: Boolean read GetFieldIsDateTime; + property FieldIsBoolean[Index: Integer]: Boolean read GetFieldIsBoolean; + property FieldIsNull[Index: Integer]: Boolean read GetFieldIsNull; + + property AsText[Index: Integer]: String read GetAsText write SetAsText; + property AsString[Index: Integer]: String read GetAsString write SetAsString; + property AsInteger[Index: Integer]: Integer read GetAsInteger write SetAsInteger; + property AsFloat[Index: Integer]: Double read GetAsFloat write SetAsFloat; + property AsDateTime[Index: Integer]: TDateTime read GetAsDateTime write SetAsDateTime; + property AsBoolean[Index: Integer]: Boolean read GetAsBoolean write SetAsBoolean; + + property AsTextByName[FieldName: String]: String read GetAsTextByName write SetAsTextByName; + property AsStringByName[FieldName: String]: String read GetAsStringByName write SetAsStringByName; + property AsIntegerByName[FieldName: String]: Integer read GetAsIntegerByName write SetAsIntegerByName; + property AsFloatByName[FieldName: String]: Double read GetAsFloatByName write SetAsFloatByName; + property AsDateTimeByName[FieldName: String]: TDateTime read GetAsDateTimeByName write SetAsDateTimeByName; + property AsBooleanByName[FieldName: String]: Boolean read GetAsBooleanByName write SetAsBooleanByName; + + procedure GetValue(Index: Integer; var Value); + procedure SetValue(Index: Integer; var Value); + + property FieldIsMemo[Index: Integer]: Boolean read GetFieldIsMemo; + property MemoAsString[Index: Integer]: String read GetMemoAsString write SetMemoAsString; + property MemoAsStringByName[FieldName: String]: String read GetMemoAsStringByName write SetMemoAsStringByName; + + function GetMemoValue(Index: Integer; var Value: Pointer): DWord; + procedure SetMemoValue(Index: Integer; Value: Pointer; ACount: DWord; ASigna: DWord = 0); + +{ ??????? ftUnknown, ftCharacterBin, ftMemoBin, ftCurrency, ftInteger, } + + property Active: Boolean read FActive write SetActive; + property AutoUpdate: Boolean read FAutoUpdate write FAutoUpdate; + Property DBFModified: boolean read FDBFModified; + + property FileName: String read FFileName write SetFileName; + property FileNameMemo: String read FFileNameMemo write FFileNameMemo; + property Error: TDbfErrors read GetError; + + property OnScroll: TOnDbfEvent read FOnScroll write FOnScroll; + property OnDelete: TOnDbfEvent read FOnDelete write FOnDelete; + property OnAppend: TOnDbfEvent read FOnAppend write FOnAppend; + end; + +function NewmdvDBF(AFileName: String; AutoUpdate: Boolean; ReadOnly: Boolean = False): TKOLmdvDBF; + +implementation + +function NewmdvDBF(AFileName: String; AutoUpdate: Boolean; ReadOnly: Boolean = False): TKOLmdvDBF; +begin + New(Result, Create); + Result.FAutoUpdate:= AutoUpdate; + Result.FFileName:= AFileName; + Result.FReadOnly:= ReadOnly; +end; + +{ TmdvDBF } + +procedure TmdvDBF.Append; +var Allowed: Boolean; +begin + if not FActive or FReadOnly then Exit; + if FAutoUpdate then Post; + Allowed:= True; + if Assigned(FOnAppend) then FOnAppend(@Self, Allowed); + if not Allowed then Exit; + FDBFHeader.RecordCount:= FDBFHeader.RecordCount + 1; + try + FDBFStream.Seek(0, spBegin); FDBFStream.Write(FDBFHeader, SizeOf(FDBFHeader)); + FCurrentRecord:= FDBFHeader.RecordCount-1; + FillMemory(FRecordBuffer, FDBFHeader.RecordLength, $20); + FRecordModified:= True; + Post; + except + FError:= eAppendRecord; + FDBFHeader.RecordCount:= FDBFHeader.RecordCount-1; + end; +end; + +destructor TmdvDBF.Destroy; +begin + Active:= False; + inherited; +end; + +procedure TmdvDBF.First; +begin + SetCurrentRecord(0); + FBOF:= FCurrentRecord=0; FEOF:= False; +end; + +function TmdvDBF.GetAsBoolean(Index: Integer): Boolean; +begin + Result:= False; + try + if not FieldIsString[Index] then Exit; + Result:= (AsText[Index][1] in ['T', 't', 'Y', 'y']) + except + FError:= eReadField; + end; +end; + +function TmdvDBF.GetAsDateTime(Index: Integer): TDateTime; +var SS, S: String; +begin + Result:= 0; + try + if not FieldIsDateTime[Index] then Exit; + SetLength(S, 14); + FillMemory(PChar(S), 14, Byte('0')); + SS:= AsText[Index]; + Move(SS[1], S[1], Length(SS)); + Result:= Str2DateTimeFmt('yyyyMMddHHmmss', S); + except + FError:= eReadField; + end; +end; + +function TmdvDBF.GetAsFloat(Index: Integer): Double; +begin + Result:= 0; + try + if not FieldIsFloat[Index] then Exit; + Result:= Str2Double(Trim(AsText[Index])); + except + FError:= eReadField; + end; +end; + +function TmdvDBF.GetAsInteger(Index: Integer): Integer; +begin + Result:= 0; + try + if not FieldIsInteger[Index] then Exit; + Result:= Str2Int(Trim(AsText[Index])); + except + FError:= eReadField; + end; +end; + +function TmdvDBF.GetAsString(Index: Integer): String; +var S: String; + D: TDateTime; +begin + Result:= ''; + try + if not FieldIsString[Index] then Exit; + S:= AsText[Index]; + case FieldType[Index] of + ftCharacter: Result:= TrimRight(S); + ftDate, ftDateTime: begin + D:= AsDateTime[Index]; + Result:= Date2StrFmt('dd.MM.yyyy', D); + if FieldType[Index] = ftDateTime then + Result:= Result + Time2StrFmt(' HH:mm:ss', D); + end; + ftLogical: if S[1] in ['T', 't', 'Y', 'y', 'F', 'f', 'N', 'n'] then Result:= S[1] else Result:= 'F'; + ftFloat, ftNumeric: begin + Result:= Double2Str(AsFloat[Index]); + end; + end; + except + FError:= eReadField; + end; +end; + +function TmdvDBF.GetError: TDbfErrors; +begin + Result:= FError; + FError:= eNoErrors; +end; + +function TmdvDBF.GetFieldDecimals(Index: Integer): Byte; +begin + Result:= FDBFFields[Index].Decimals; +end; + +function TmdvDBF.GetFieldIsBoolean(Index: Integer): Boolean; +begin + Result:= FieldType[Index] = ftLogical; +end; + +function TmdvDBF.GetFieldIsDateTime(Index: Integer): Boolean; +begin + Result:= FieldType[Index] in [ftDate, ftDateTime]; +end; + +function TmdvDBF.GetFieldIsFloat(Index: Integer): Boolean; +begin + Result:= FieldType[Index] in [ftFloat, ftNumeric]; +end; + +function TmdvDBF.GetFieldIsInteger(Index: Integer): Boolean; +begin + Result:= (FieldType[Index] in [ftFloat, ftNumeric])and(FDBFFields[Index].Decimals = 0); +end; + +function TmdvDBF.GetFieldIsMemo(Index: Integer): Boolean; +begin + Result:= FieldType[Index] in [ftMemo, ftGeneral, ftBinary, ftPicture]; +end; + +function TmdvDBF.GetFieldIsNull(Index: Integer): Boolean; +begin + Result:= ((FDBFFields[Index].FieldFlags and $02) = $02); +end; + +function TmdvDBF.GetFieldIsString(Index: Integer): Boolean; +begin + Result:= FieldType[Index] in [ftCharacter, ftDate, ftLogical, ftFloat, ftNumeric, ftDateTime]; +end; + +function TmdvDBF.GetFieldLength(Index: Integer): Byte; +begin + Result:= FDBFFields[Index].FieldLength; +end; + +function TmdvDBF.GetFieldName(Index: Integer): String; +begin + Result:= FDBFFields[Index].FieldName; +end; + +function TmdvDBF.GetFieldNumber(NameField: String): Integer; +var i: Integer; +begin + Result:= -1; + for i:= 0 to FFieldsCount-1 do + if String(PChar(@FDBFFields[i].FieldName)) = NameField then begin + Result:= i; Break; + end; +end; + +function TmdvDBF.GetFieldType(Index: Integer): TFieldType; +begin + case FDBFFields[Index].FieldType of + 'C': if (FDBFFields[Index].FieldFlags and $04)=$04 then Result:= ftCharacterBin else Result:= ftCharacter; + 'Y': Result:= ftCurrency; + 'N': Result:= ftNumeric; + 'F': Result:= ftFloat; + 'D': Result:= ftDate; + 'T': Result:= ftDateTime; + 'B': Result:= ftBinary; + 'I': Result:= ftInteger; + 'L': Result:= ftLogical; + 'M': if (FDBFFields[Index].FieldFlags and $04)=$04 then Result:= ftMemoBin else Result:= ftMemo; + 'G': Result:= ftGeneral; + 'P': Result:= ftPicture; + else Result:= ftUnknown; + end; +end; + +function TmdvDBF.GetHasMemo: Boolean; +begin + Result:= FDBFHeader.TableFlags and $02 = $02; +end; + +function TmdvDBF.InvertDWord(var Value: DWord): DWord; +type TB = array[0..3] of Byte; +begin + TB(Result)[0]:= TB(Value)[3]; + TB(Result)[1]:= TB(Value)[2]; + TB(Result)[2]:= TB(Value)[1]; + TB(Result)[3]:= TB(Value)[0]; +end; + +function TmdvDBF.GetIsDelete: Boolean; +begin + Result:= False; + if not FActive then Exit; + Result:= (FRecordBuffer^[0] = $2A) +end; + +function TmdvDBF.GetLastUpdated: TDateTime; +begin + EncodeDate(FDBFHeader.LastUpdated[1], FDBFHeader.LastUpdated[2], FDBFHeader.LastUpdated[3], Result); +end; + +function TmdvDBF.GetMemoAsString(Index: Integer): String; +var P: Pointer; + Sz: DWord; +begin + Sz:= GetMemoValue(Index, P); + SetLength(Result, Sz); + if Sz > 0 then begin + Move(P^, Result[1], Sz); + DisposeMem(P); + end; +end; + +function TmdvDBF.GetMemoValue(Index: Integer; var Value: Pointer): DWord; +var BlockNum, BlockSize, BlockCount: DWord; + k: Integer; + MemoType: TMemoType; +begin + Value:= nil; Result:= 0; + MemoType:= GetMemoInfo(Index, BlockNum, BlockSize, BlockCount, Result); + if (BlockCount = 0) or (BlockNum = 0) or (MemoType = mtUnknown) then Exit; + + case MemoType of + mtFoxPro, mtdBaseIV: begin + FDBFMemoStream.Seek(BlockNum * BlockSize+SizeOf(TMemoBlockHeader), spBegin); + Value:= AllocMem(Result); + FDBFMemoStream.Read(Value^, Result); + end; + mtdBase: begin + FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin); + Result:= 0; + repeat + inc(Result, BlockSize); ReallocMem(Value, Result+1); + FDBFMemoStream.Read(PChar(Value)[Result-512], BlockSize); + PChar(Value)[Result+1]:= #0; + k:= Pos(#$1A, PChar(Value)); + if k>0 then begin + Result:= k-1; + ReallocMem(Value, Result); + Break; + end; + until FDBFMemoStream.Position >= FDBFMemoStream.Size; + end; + end; +end; + +procedure TmdvDBF.GetValue(Index: Integer; var Value); +begin + try + Move(FRecordBuffer^[FDBFFields[Index].Address], Value, FDBFFields[Index].FieldLength); + except + FError:= eReadField; + end; +end; + +procedure TmdvDBF.Last; +begin + SetCurrentRecord(FDBFHeader.RecordCount-1); + FBOF:= False; FEOF:= FCurrentRecord = FDBFHeader.RecordCount-1; +end; + +procedure TmdvDBF.Next; +begin + SetCurrentRecord(FCurrentRecord+1); + FBOF:= False; FEOF:= FCurrentRecord = FDBFHeader.RecordCount-1; +end; + +procedure TmdvDBF.Post; +begin + if FRecordModified then WriteRecord; +end; + +procedure TmdvDBF.Prev; +begin + SetCurrentRecord(FCurrentRecord-1); + FBOF:= FCurrentRecord=0; FEOF:= False; +end; + +function TmdvDBF.ReadFields: Boolean; +var DBFField: TDBFField; + Addr: DWord; +begin + try + Result:= True; + FFieldsCount:= 0; + FDBFFields:= AllocMem(SizeOf(TDBFField)*((FDBFHeader.HeaderLength - SizeOf(TDBFHeader)) div SizeOf(TDBFField))); + FDBFStream.Seek(SizeOf(TDBFHeader), spBegin); FHasMemo:= False; + Addr:= 1; + repeat + FDBFStream.Read(DBFField, SizeOf(TDBFField)); + if DBFField.FieldName[1] <> #13 then begin + if DBFField.Address = 0 then DBFField.Address:= Addr; + FDBFFields[FFieldsCount]:= DBFField; + FHasMemo:= FHasMemo or FieldIsMemo[FFieldsCount]; + inc(FFieldsCount); + end; + inc(Addr, DBFField.FieldLength); + until DBFField.FieldName[1] = #13; + except + Result:= False; + FError:= eDBFHeader; + end; +end; + +procedure TmdvDBF.ReadRecord; +Begin + if not FActive then Exit; + try + FDBFStream.Seek(FDBFHeader.HeaderLength + FCurrentRecord*FDBFHeader.RecordLength, spBegin); + FDBFStream.Read(FRecordBuffer^, FDBFHeader.RecordLength); + FRecordModified := False; + except + FError:= eReadRecord; + end; +end; + +procedure TmdvDBF.RefreshRecord; +begin + if not FActive then Exit; + ReadRecord; +end; + +procedure TmdvDBF.SetActive(const Value: Boolean); +const ReadWrite: array [Boolean] of DWord = (ofOpenReadWrite, ofOpenRead); +// Stream: PStream; +begin + if Value = FActive then Exit; + if Value then begin + if not FileExists(FFileName) then begin FError:= eFileNotExist; Exit; end; + FDBFStream:= NewFileStream(FFileName, ReadWrite[FReadOnly] or ofShareDenyNone or{ofShareDenyWrite or }ofOpenExisting); + if FDBFStream.Handle = 0 then begin FError:= eFileOpen; Exit; end; + +{FDBFStream:= NewMemoryStream; +Stream:= NewReadFileStream(FFileName); +FDBFStream.Size:= Stream.Size; +Stream.Read(FDBFStream.Memory^, Stream.Size); +Stream.Free;} + FDBFStream.Read(FDBFHeader, SizeOf(TDBFHeader)); + if not ReadFields then Exit; + FRecordBuffer:= AllocMem(FDBFHeader.RecordLength); + + if FHasMemo then begin + if not FileExists(FFileNameMemo) then begin + FFileNameMemo:= ChangeFileExt(FFileName, '.fpt'); + if not FileExists(FFileNameMemo) then begin + FFileNameMemo:= ChangeFileExt(FFileName, '.dbt'); + if not FileExists(FFileNameMemo) then begin + FFileNameMemo:= ''; + end; + end; + end; + if FFileNameMemo <> '' then begin + + FDBFMemoStream:= NewFileStream(FFileNameMemo, ReadWrite[FReadOnly] {or ofShareDenyWrite }or ofShareDenyNone or ofOpenExisting); +{FDBFMemoStream:= NewMemoryStream; +Stream:= NewReadFileStream(FFileNameMemo); +FDBFMemoStream.Size:= Stream.Size; +Stream.Read(FDBFMemoStream.Memory^, Stream.Size); +Stream.Free;} + + if FDBFHeader.DBFType in [DBF_FoxPro2xMemo, DBF_VisualFoxPro, DBF_VisualFoxProInc] then FDBFMemoStream.Read(FFPTHeader, SizeOf(TFPTHeader)) + else FDBFMemoStream.Read(FDBTHeader, SizeOf(TDBTHeader)); + end + else FHasMemo:= False; + end; + + FCurrentRecord:= 0; FDBFModified:= False; FRecordModified:= False; + FEOF:= False; FBOF:= False; + FActive := True; + end + else begin + if FAutoUpdate then Post; + if FDBFModified and not FReadOnly then begin + SetDate(FDBFHeader.LastUpdated); + FDBFStream.Seek(0, spBegin); FDBFStream.Write(FDBFHeader, SizeOf(TDBFHeader)); + end; + DisposeMem(Pointer(FDBFFields)); + DisposeMem(Pointer(FRecordBuffer)); + FDBFStream.Free; + if FHasMemo then FDBFMemoStream.Free; + FFileNameMemo:= ''; + FActive := False; + end +end; + +procedure TmdvDBF.SetAsBoolean(Index: Integer; const Value: Boolean); +begin + if Value then AsString[Index]:= 'T' else AsString[Index]:= 'F'; +end; + +procedure TmdvDBF.SetAsDateTime(Index: Integer; const Value: TDateTime); +begin + AsString[Index]:= Date2StrFmt('yyyyMMdd', Value)+Time2StrFmt('HHmmss', Value); +end; + +procedure TmdvDBF.SetAsFloat(Index: Integer; const Value: Double); +begin + AsString[Index]:= Double2Str(Value); +end; + +procedure TmdvDBF.SetAsInteger(Index: Integer; const Value: Integer); +begin + AsString[Index]:= Int2Str(Value); +end; + +procedure TmdvDBF.SetAsString(Index: Integer; const Value: String); +var S, SS, I: String; + ValidValue: Boolean; + lI, lp, lF, k: Integer; + D: TDateTime; +begin + try + S:= Value; + ValidValue:= False; + case FieldType[Index] of + ftCharacter: begin + ValidValue:= True; + end; + ftDate, ftDateTime: begin + D:= Str2DateTimeFmt('yyyyMMddHHmmss', Value); S:= Value; + ValidValue:= (Value = Date2StrFmt('yyyyMMdd', D)+Time2StrFmt('HHmmss', D)); + end; + ftLogical: begin + ValidValue:= (Length(Value)=1); + if ValidValue then ValidValue:= Value[1] in ['T', 't', 'Y', 'y', 'F', 'f', 'N', 'n']; + end; + ftFloat, ftNumeric: begin + SS:= Trim(Value); + ValidValue:= Double2Str((Str2Double(SS))) = SS; + if ValidValue then begin + lP:= FDBFFields[Index].FieldLength - FDBFFields[Index].Decimals; + lI:= FDBFFields[Index].FieldLength - FDBFFields[Index].Decimals - 1; + lF:= FDBFFields[Index].Decimals; + if FDBFFields[Index].Decimals = 0 then begin + lI:= FDBFFields[Index].FieldLength; lF:= 0; lP:= 0; + end; + if FDBFFields[Index].FieldLength <= FDBFFields[Index].Decimals then begin + lI:= 0; lF:= FDBFFields[Index].FieldLength; lP:= 0; + end; + if lP > 0 then S:= '.' else S:=''; + + I:= Parse(SS, '.'); + lP:= Min(Length(I), lI); + SetLength(I, lP); + for k:= lP to lI-1 do I:= ' '+I; + + lP:= Min(Length(SS), lF); + SetLength(SS, lP); + for k:= lP to lF-1 do SS:= SS+'0'; + S:= I+S+SS; + end; + end; + end; + if ValidValue then begin + FillMemory(@(FRecordBuffer^[FDBFFields[Index].Address]), FDBFFields[Index].FieldLength, Byte(' ')); + SetString(Index, S); + end + else FError:= eInvalidValue; + except + FError:= eWriteField; + end; +end; + +procedure TmdvDBF.SetCurrentRecord(const Value: DWord); +var Allowed: Boolean; +begin + if not FActive then Exit; + Allowed:= True; + if Assigned(FOnScroll) then FOnScroll(@Self, Allowed); + if not Allowed then Exit; + if FAutoUpdate then Post; + FCurrentRecord := Max(0, Min(FDBFHeader.RecordCount-1, Value)); + ReadRecord; +end; + +procedure TmdvDBF.SetFileName(const Value: String); +begin + if FFileName <> Value then begin + Active:= False; + FFileName := Value; + end; +end; + +procedure TmdvDBF.SetIsDelete(const Value: Boolean); +const DelFlag: array [Boolean] of Byte = ($20, $2A); +var Allowed: Boolean; +begin + if not FActive then Exit; + Allowed:= True; + if Assigned(FOnDelete) then FOnDelete(@Self, Allowed); + if not Allowed then Exit; + FRecordBuffer^[0] := DelFlag[Value]; + FRecordModified:= True; +end; + +procedure TmdvDBF.SetMemoAsString(Index: Integer; Value: String); +begin + SetMemoValue(Index, PChar(Value), Length(Value), 1); +end; + +procedure TmdvDBF.SetMemoValue(Index: Integer; Value: Pointer; ACount: DWord; ASigna: DWord = 0); +var BSize, BlockNum, BlockSize, BlockCount, Size, mh: DWord; + MemoType: TMemoType; + MemoBlockHeader: TMemoBlockHeader; + S: String; +begin + if FReadOnly then Exit; + + MemoType:= GetMemoInfo(Index, BlockNum, BlockSize, BlockCount, Size); + if (BlockCount = 0) or (MemoType = mtUnknown) then Exit; + + if MemoType <> mtdBase then mh:= SizeOf(TMemoBlockHeader) else mh:= 1; + BSize:= Size+mh; + BSize:= (BSize div BlockSize)*BlockSize + BlockSize*DWord(Ord((BSize mod BlockSize)>0)); + if (BlockNum = 0) or (BSize < ACount + mh) then begin + BSize:= ACount + mh; + BSize:= (BSize div BlockSize)*BlockSize + BlockSize*DWord(Ord((BSize mod BlockSize)>0)); + BlockNum:= BlockCount; + BlockCount:= BlockCount + BSize div BlockSize; + end; + FDBFMemoStream.Size:= BlockCount * BlockSize; + FDBFMemoStream.Seek(0, spBegin); + + if MemoType = mtFoxPro then begin + MemoBlockHeader.Length:= InvertDWord(ACount); + MemoBlockHeader.BlockSignature:= InvertDWord(ASigna); + FFPTHeader.NextFree:= InvertDWord(BlockCount); + FDBFMemoStream.Write(FFPTHeader, SizeOf(TFPTHeader)); + end + else begin + MemoBlockHeader.Length:= ACount + 8; + if MemoType = mtdBaseIV then MemoBlockHeader.BlockSignature:= $08FFFF + else MemoBlockHeader.BlockSignature:= ASigna; + FDBTHeader.NextFree:= BlockCount; + FDBFMemoStream.Write(FDBTHeader, SizeOf(TDBTHeader)); + end; + + if FDBFFields[Index].FieldLength = 4 then + SetValue(Index, BlockNum) + else begin + S:= Int2Str(BlockNum); + for mh:= Length(S)+1 to FDBFFields[Index].FieldLength do S:= ' '+S; + SetValue(Index, S[1]); + end; + Post; + + case MemoType of + mtFoxPro, mtdBaseIV: begin + FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin); + FDBFMemoStream.Write(MemoBlockHeader, SizeOf(TMemoBlockHeader)); + FDBFMemoStream.Write(Value^, ACount); + end; + mtdBase: begin + FDBFMemoStream.Seek(BlockNum * BlockSize, spBegin); + FDBFMemoStream.Write(Value^, ACount); + S:= #$1A; + FDBFMemoStream.Write(S[1], 1); + end; + end; +end; + +procedure TmdvDBF.SetString(Index: Integer; Value: String); +begin + try + Move(Value[1], FRecordBuffer^[FDBFFields[Index].Address], Min(Length(Value), FDBFFields[Index].FieldLength)); + FDBFModified:= True; + FRecordModified:= True; + except + FError:= eWriteField; + end; +end; + +procedure TmdvDBF.SetValue(Index: Integer; var Value); +begin + try + Move(Value, FRecordBuffer^[FDBFFields[Index].Address], FDBFFields[Index].FieldLength); + FDBFModified:= True; + FRecordModified:= True; + except + FError:= eWriteField; + end; +end; + +procedure TmdvDBF.WriteRecord; +Begin + if not FActive or FReadOnly then Exit; + try + FDBFStream.Seek(FDBFHeader.HeaderLength + FCurrentRecord*FDBFHeader.RecordLength, spBegin); + FDBFStream.Write(FRecordBuffer^, FDBFHeader.RecordLength); + FRecordModified := False; + FDBFModified:= True; + except + FError:= eWriteRecord; + end; +end; + +function TmdvDBF.GetAsText(Index: Integer): String; +begin + Result:= ''; + try + if not FieldIsString[Index] then Exit; + SetLength(Result, FDBFFields[Index].FieldLength); + Move(FRecordBuffer^[FDBFFields[Index].Address], Result[1], FDBFFields[Index].FieldLength); + except + FError:= eReadField; + end; +end; + +procedure TmdvDBF.SetAsText(Index: Integer; Value: String); +begin + try + FillMemory(@(FRecordBuffer^[FDBFFields[Index].Address]), FDBFFields[Index].FieldLength, Byte(' ')); + SetValue(Index, Value[1]); + except + FError:= eWriteField; + end; +end; + +function TmdvDBF.GetMemoInfo(Index: Integer; var ABlockNum, ABlockSize, ABlockCount, ASize: DWord): TMemoType; +var S: String; + MemoBlockHeader: TMemoBlockHeader; +begin + ABlockNum:=0; ABlockSize:=0; ABlockCount:=0; ASize:= 0; + Result:= mtUnknown; + if not FieldIsMemo[Index] then Exit; + + if FDBFFields[Index].FieldLength = 4 then + Move(FRecordBuffer^[FDBFFields[Index].Address], ABlockNum, 4) + else begin + SetLength(S, FDBFFields[Index].FieldLength); + Move(FRecordBuffer^[FDBFFields[Index].Address], S[1], FDBFFields[Index].FieldLength); + ABlockNum:= Str2Int(Trim(S)); + end; + + if FDBFHeader.DBFType in [DBF_FoxPro2xMemo, DBF_VisualFoxPro, DBF_VisualFoxProInc] then Result:= mtFoxPro; + if FDBFHeader.DBFType in [DBF_dBaseIV, DBF_dBaseIVSQLtable, DBF_dBaseIVSQLsystem, DBF_dBaseIVSQLtableMemo, DBF_dBaseIVMemo, DBF_dBaseV] then Result:= mtdBaseIV; + if FDBFHeader.DBFType in [DBF_FoxBASE, DBF_FoxBASE_, DBF_dBaseIIIplus, DBF_dBaseIIIplusMemo] then Result:= mtdBase; + + ABlockSize:= 512; + ABlockCount:= FDBTHeader.NextFree; + ASize:= 0; + + if Result = mtFoxPro then begin + ABlockSize:= System.Swap(FFPTHeader.BlockSize); + ABlockCount:= InvertDWord(FFPTHeader.NextFree); + end; + if Result = mtdBaseIV then begin + ABlockSize:= FDBTHeader.BlockSize; + end; + if ABlockSize = 0 then ABlockSize:= 512; + + if ABlockNum = 0 then Exit; + FDBFMemoStream.Seek(ABlockNum * ABlockSize, spBegin); + FDBFMemoStream.Read(MemoBlockHeader, SizeOf(TMemoBlockHeader)); + + if Result = mtFoxPro then ASize:= InvertDWord(MemoBlockHeader.Length); + if Result = mtdBaseIV then ASize:= MemoBlockHeader.Length - 8; +end; + +procedure TmdvDBF.PackDBF; +var ReadPos, WritePos, Rec, RecCount: DWord; +begin + if FReadOnly then Exit; + Post; + ReadPos:= FDBFHeader.HeaderLength; WritePos:= FDBFHeader.HeaderLength; + Rec:= 0; RecCount:= 0; + while Rec < FDBFHeader.RecordCount do begin + FDBFStream.Seek(ReadPos, spBegin); + FDBFStream.Read(FRecordBuffer^, FDBFHeader.RecordLength); + inc(ReadPos, FDBFHeader.RecordLength); + inc(Rec); + if FRecordBuffer^[0] <> $2A then begin + FDBFStream.Seek(WritePos, spBegin); + FDBFStream.Write(FRecordBuffer^, FDBFHeader.RecordLength); + inc(WritePos, FDBFHeader.RecordLength); + inc(RecCount); + end + else FDBFModified:= True; + end; + FDBFStream.Size:= WritePos; + + FDBFHeader.RecordCount := RecCount; + FDBFStream.Seek(0, spBegin); + FDBFStream.Write(FDBFHeader, SizeOf(TDBFHeader)); + + CurrentRecord:= 0; +end; + +function TmdvDBF.Locate(AFieldName, AValue: String): Boolean; +var i, FieldNum: Integer; +begin + Result:= False; + FieldNum:= FieldNumber[AFieldName]; + if FieldNum<0 then Exit; + for i:= 0 to RecordCount-1 do begin + CurrentRecord:= i; + if IsDelete then Continue; + Result:= AsString[FieldNum] = AValue; + if Result then Break; + end; +end; + +function TmdvDBF.Locate(AFieldNames, AValues: array of String): Boolean; +var i, j: Integer; + FieldNums: array of Integer; +begin + Result:= False; + SetLength(FieldNums, Min(Length(AFieldNames), Length(AValues))); + try + for j:= Low(FieldNums) to High(FieldNums) do begin + FieldNums[j]:= FieldNumber[AFieldNames[j]]; + if FieldNums[j]<0 then Exit; + end; + for i:= 0 to RecordCount-1 do begin + CurrentRecord:= i; + if IsDelete then Continue; + Result:= True; + for j:= Low(FieldNums) to High(FieldNums) do + Result:= Result and (AsString[FieldNums[j]] = AValues[j]); + if Result then Break; + end; + finally + SetLength(FieldNums, 0); + end; +end; + +function TmdvDBF.GetAsBooleanByName(AFieldName: String): Boolean; +begin + Result:= AsBoolean[FieldNumber[AFieldName]]; +end; + +function TmdvDBF.GetAsDateTimeByName(AFieldName: String): TDateTime; +begin + Result:= AsDateTime[FieldNumber[AFieldName]]; +end; + +function TmdvDBF.GetAsFloatByName(AFieldName: String): Double; +begin + Result:= AsFloat[FieldNumber[AFieldName]]; +end; + +function TmdvDBF.GetAsIntegerByName(AFieldName: String): Integer; +begin + Result:= AsInteger[FieldNumber[AFieldName]]; +end; + +function TmdvDBF.GetAsStringByName(AFieldName: String): String; +begin + Result:= AsString[FieldNumber[AFieldName]]; +end; + +function TmdvDBF.GetAsTextByName(AFieldName: String): String; +begin + Result:= AsText[FieldNumber[AFieldName]]; +end; + +procedure TmdvDBF.SetAsBooleanByName(AFieldName: String; const Value: Boolean); +begin + AsBoolean[FieldNumber[AFieldName]]:= Value; +end; + +procedure TmdvDBF.SetAsDateTimeByName(AFieldName: String; const Value: TDateTime); +begin + AsDateTime[FieldNumber[AFieldName]]:= Value; +end; + +procedure TmdvDBF.SetAsFloatByName(AFieldName: String; const Value: Double); +begin + AsFloat[FieldNumber[AFieldName]]:= Value; +end; + +procedure TmdvDBF.SetAsIntegerByName(AFieldName: String; const Value: Integer); +begin + AsInteger[FieldNumber[AFieldName]]:= Value; +end; + +procedure TmdvDBF.SetAsStringByName(AFieldName: String; const Value: String); +begin + AsString[FieldNumber[AFieldName]]:= Value; +end; + +procedure TmdvDBF.SetAsTextByName(AFieldName: String; const Value: String); +begin + AsText[FieldNumber[AFieldName]]:= Value; +end; + +function TmdvDBF.GetMemoAsStringByName(AFieldName: String): String; +begin + Result:= MemoAsString[FieldNumber[AFieldName]]; +end; + +procedure TmdvDBF.SetMemoAsStringByName(AFieldName: String; const Value: String); +begin + MemoAsString[FieldNumber[AFieldName]]:= Value; +end; + +function TmdvDBF.MaxOfField(AFieldName: String): Integer; +var i, FieldNum, k: Integer; +begin + Result:= 0; + FieldNum:= FieldNumber[AFieldName]; + k:= CurrentRecord; + if FieldNum<0 then Exit; + for i:= 0 to RecordCount-1 do begin + CurrentRecord:= i; + if IsDelete then Continue; + Result:= Max(Result, AsInteger[FieldNum]); + end; + CurrentRecord:= k; +end; + +function TmdvDBF.NewDbf(AFileName: String; DescriptionDBF: String): Boolean; +var IsMemo: Boolean; + i, _FieldsCount, _RecordLength, _BlockSize: Word; + _CodePage: Byte; + _DBFHeader: TDBFHeader; + _DBFFields: PDBFFields; + _DBTHeader: TDBTHeader; + S, SS: String; + Addr: DWord; + Stream: PStream; +begin + Active:= False; + Result:= False; + + S:= Parse(DescriptionDBF, #1); + _CodePage:= Str2Int(Parse(S, #2)); + _BlockSize:= Str2Int(S); + + _FieldsCount:= 0; S:= DescriptionDBF; + while S <> '' do begin + Parse(S, #1); Inc(_FieldsCount); + end; + if (_FieldsCount = 0) or (_FieldsCount > 255) then Exit; + + GetMem(_DBFFields, _FieldsCount*SizeOf(TDBFField)); + try + IsMemo:= False; + i:= 0; Addr:= 1; _RecordLength:= 1; + while DescriptionDBF <> '' do begin + S:= Parse(DescriptionDBF, #1); + FillChar(_DBFFields^[i], SizeOf(TDBFFields), 0); + with _DBFFields[i] do begin + // Название поля + SS:= Parse(S, #2); + if (SS = '') or (Length(SS) > 10) then Exit; + Move(SS[1], FieldName, Length(SS)); + // Тип поля 'C' - Character; 'N' - Numeric; 'D' - Date; 'B' - Binary; 'L' - Logical, 'M' - Memo + SS:= Parse(S, #2); + if (SS = '') or (Length(SS) <> 1) then Exit; + FieldType:= SS[1]; + // Длина поля (в байтах) + FieldLength:= Str2Int(Parse(S, #2)); + case FieldType of + 'C': if (FieldLength = 0) or (FieldLength > 254) then Exit; + 'N': if (FieldLength = 0) or (FieldLength > 20) then Exit; + 'D': FieldLength:= 8; + 'L': FieldLength:= 1; + 'B', 'M': begin + FieldLength:= 10; + IsMemo:= True; + end; + else Exit; + end; + // Длина десятичной части + SS:= Parse(S, #2); + if FieldType = 'N' then + Decimals:= Max(0, Min(FieldLength-1, Str2Int(SS))); + // Флаг поля +// if FieldType in ['B', 'M'] then FieldFlags:= $04; +// if FieldType = 'C' then FieldFlags:= FieldFlags or $02; + + Address:= Addr; + inc(_RecordLength, FieldLength); + inc(Addr, FieldLength); + end; + + inc(i); + end; + + FillChar(_DBFHeader, SizeOf(_DBFHeader), 0); + with _DBFHeader do begin + if IsMemo then DBFType:= DBF_dBaseIVMemo else DBFType:= DBF_dBaseIV; // Тип файла (DBF_xxx) + SetDate(LastUpdated); // Дата последнего обновления в формате YYMMDD + RecordCount:= 0; // Количество записей в таблице + HeaderLength:= SizeOf(_DBFHeader) + _FieldsCount * SizeOf(TDBFField) + 1; // Количество байт, занимаемых заголовком + RecordLength:= _RecordLength; // Количество байт, занимаемых записью + //Reserved_1: array [1..16] of Byte; // 3-Зарезервированная область; 13 - Зарезервировано для сетевой версии dBASE III PLUS + if IsMemo then TableFlags:= $02; // $01 - file has a structural .cdx; $02 - file has a Memo field; $04 - file is a database (.dbc). This byte can contain the sum of any of the above values. For example, the value 0x03 indicates the table has a structural .cdx and a Memo field. + CodePage:= _CodePage; // Кодовая страница + //Reserved_2: Word; // Зарезервированная область + end; + + Stream:= NewWriteFileStream(AFileName); + Stream.Size:= 0; + Stream.Write(_DBFHeader, SizeOf(_DBFHeader)); + for i:= 0 to _FieldsCount-1 do + Stream.Write(_DBFFields[i], SizeOf(TDBFFields)); + + S:= #$0D#$1A; + Stream.Write(S[1], 2); + Stream.Free; + + if IsMemo then begin + _BlockSize:= Max(_BlockSize, SizeOf(_DBTHeader)); + FillChar(_DBTHeader, SizeOf(_DBTHeader), 0); + + with _DBTHeader do begin + NextFree:= 512 div _BlockSize + Ord(512 mod _BlockSize > 0); + BlockSize:= _BlockSize; + end; + end; + Stream:= NewWriteFileStream(ChangeFileExt(AFileName, '.dbt')); + Stream.Size:= 0; + Stream.Write(_DBTHeader , SizeOf(_DBTHeader)); + Stream.Size:= _DBTHeader.NextFree*_DBTHeader.BlockSize; + Stream.Free; + + finally + FreeMem(_DBFFields); + end; + + + FFileName:= AFileName; + Active:= True; + Result:= True; +end; + +procedure TmdvDBF.SetDate(var ADate: TYYMMDD); +var Y, M, D: Word; +begin + DecodeDate(Now, Y, M, D); + ADate[1]:= Lo(Y mod 100); ADate[2]:= Lo(M); ADate[3]:= Lo(D); +end; + +end. diff --git a/Addons/KOLmhxp.pas b/Addons/KOLmhxp.pas new file mode 100644 index 0000000..e064786 --- /dev/null +++ b/Addons/KOLmhxp.pas @@ -0,0 +1,53 @@ +unit KOLMHXP; +// MHXP Компонент (MHXP Component) +// Автор (Author): Жаров Дмитрий (Zharov Dmitry) aka Гэндальф (Gandalf) +// Дата создания (Create date): 14-ноя(nov)-2001 +// Дата коррекции (Last correction Date): 21-апр(apr)-2003 +// Версия (Version): 1.17 +// EMail: Gandalf@kol.mastak.ru +// WWW: http://kol.mastak.ru +// Благодарности (Thanks): +// Alexander Pravdin +// Новое в (New in): +// V1.17 +// [+] Внешний манифест (External manifest) [KOLnMCK] +// +// V1.16 +// [+] Поддержка D7 (D7 Support) [KOLnMCK] +// +// V1.15 +// [+] Поддержка D6 (D6 Support) [KOLnMCK] +// +// V1.14 +// [!.] Немного подправил (Small Fixing) [MCK] +// +// V1.13 +// [+] Tag [MCK] +// [*] Code MCK Optim-z [MCK] +// +// V1.12 +// [*] Hide Tag as unused [MCK] +// [*] Del Unused modules [MCK] +// +// V1.11 +// [*] Needn't to create and free KOLObj [MCK] +// [*] Nearly clear KOL-file [KOL] +// +// V1.1 +// [!] Resource Compile [MCK] +// +// Список дел (To-Do list): +// 1. Оптимизировать (Optimize) +// 2. Подчистить (Clear Stuff) +// 3. XP должен быть один на проект (XP in Project must be ONE) + +interface + + + +type + TKOLMHXP = Pointer; + +implementation + +end. diff --git a/Addons/ListEdit.pas b/Addons/ListEdit.pas new file mode 100644 index 0000000..8ded923 --- /dev/null +++ b/Addons/ListEdit.pas @@ -0,0 +1,264 @@ +unit ListEdit; + +interface +uses KOL, Windows, Messages, objects; + +const + WM_JUSTFREE = WM_USER + 51; + WM_EDITFREE = WM_USER + 52; + WM_DBLCLICK = WM_USER + 53; + WM_ROWCHANG = WM_USER + 54; + +type + + PListEdit =^TListEdit; + TKOLListEdit = PControl; + TListEdit = object(Tobj) + EList: PList; + Enter: boolean; + LView: PControl; + TabSave: boolean; + TabStrt: boolean; + OldWind: longint; + NewWind: longint; + CurEdit: integer; + destructor destroy; virtual; + procedure SetEvents(LV: PControl); + procedure NewWndProc(var Msg: TMessage); + procedure LVPaint; + procedure LVDblClk; + procedure LVChange(Store: boolean); + procedure PostFree(var Key: integer); + procedure EDChar(Sender: PControl; var Key: integer; Sh: Cardinal); + procedure EDPres(Sender: PControl; var Key: integer; Sh: Cardinal); + procedure EDentr(Sender: PObj); + end; + +function NewListEdit(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; + ImageListSmall, ImageListNormal, ImageListState: PImageList): PControl; + +implementation + +function NewListEdit; +var p: PListEdit; +begin + Result := NewListView(AParent, Style, Options, ImageListSmall, ImageListNormal, ImageListState); + Result.CreateWindow; + New(p, create); + AParent.Add2AutoFree(p); + p.LView := Result; + p.SetEvents(PControl(Result)); +end; + +destructor TListEdit.destroy; +begin + LVChange(False); + EList.Free; + SetWindowLong(LView.Handle, GWL_WNDPROC, OldWind); + FreeObjectInstance(Pointer(NewWind)); + inherited; +end; + +procedure TListEdit.SetEvents; +begin + EList := NewList; + Enter := False; + TabStrt := False; + OldWind := GetWindowLong(LV.Handle, GWL_WNDPROC); + NewWind := LongInt(MakeObjectInstance(NewWndProc)); + SetWindowLong(LV.Handle, GWL_WNDPROC, NewWind); +end; + +procedure TListEdit.NewWndProc; +var e: boolean; +begin + e := EList.Count > 0; + case Msg.Msg of +WM_LBUTTONDOWN: + begin + LVChange(True); + CurEdit := 0; + if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); + end; +WM_LBUTTONDBLCLK: + begin + LVDblClk; + end; +WM_KEYDOWN: + begin + if Msg.WParam = 13 then begin + LVDblClk; + end else +{ if Msg.WParam = 27 then begin + LVChange(False); + end else begin + LVChange(True); + if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); + end;} + end; +WM_NCPAINT: + begin + LVPaint; + end; +WM_JUSTFREE: + begin + LVChange(Msg.WParam <> 27); + end; +WM_EDITFREE: + begin + LVChange(Msg.WParam <> 27); + if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); + end; +WM_DBLCLICK: + begin + LVDblClk; + end; +WM_PAINT: + begin + LVPaint; + end; + end; + Msg.Result := CallWindowProc(Pointer(OldWind), LView.Handle, Msg.Msg, Msg.wParam, Msg.lParam); +end; + +procedure TListEdit.LVPaint; +var i: integer; + r: TRect; + l: integer; + e: PControl; + p: TPoint; +begin +with LView^ do begin + SendMessage(Handle, WM_SETFONT, Font.Handle, 0); + l := 0; + p := LVItemPos[0]; + for i := 0 to EList.Count - 1 do begin + r := LVItemRect(LVCurItem, lvipBounds); + r.Left := l + p.X; + r.Right := l + LVColWidth[i] + p.X; + Dec(r.Top); + Inc(r.Bottom); + e := EList.Items[i]; + e.BoundsRect := r; + l := l + LVColWidth[i]; + end; +end; +end; + +procedure TListEdit.LVDblClk; +var i: integer; + e: PControl; + r: TRect; + l: integer; + a: PControl; + p: TPoint; + o: TPoint; +begin +with LView^ do begin + if EList.Count <> 0 then LVChange(True); + if enter then exit; + enter := true; + l := 0; + a := nil; + GetCursorPos(p); + p := Screen2Client(p); + o := LVItemPos[0]; + for i := 0 to LVColCount - 1 do begin + r := LVItemRect(LVCurItem, lvipBounds); + r.Left := l + o.X; + r.Right := l + LVColWidth[i] + o.X; + l := l + LVColWidth[i]; + Dec(r.Top); + Inc(r.Bottom); + e := NewEditBox(LView, []); + EList.Add(e); + e.BoundsRect := r; + e.DoubleBuffered := True; + e.Tabstop := True; + e.Font.FontHeight := LView.Font.FontHeight; + e.Font.FontCharset := 204; + e.Text := LVItems[LVCurItem, i]; + e.OnKeyDown := EDChar; + e.OnKeyUp := EDPres; + e.OnEnter := EDEntr; + e.Show; + if a = nil then a := e; + if (CurEdit <> 0) then + if (EList.Count = CurEdit) then a := e else else + if (r.Left <= p.x) and (r.Right >= p.x) then + a := e; + end; + if a <> nil then a.Focused := True; + TabSave := TabStop; + TabStop := False; + TabStrt := True; + enter := false; +end; +end; + +procedure TListEdit.LVChange; +var e: PControl; + i: integer; + g: boolean; +begin +with LView^ do begin + if enter then exit; + enter := true; + g := False; + for i := 0 to EList.Count - 1 do begin + e := EList.Items[i]; + if Store then begin + g := g or (LVItems[LVCurItem, i] <> e.Text); + LVItems[LVCurItem, i] := e.Text; + end; + if e.Focused then CurEdit := i + 1; + e.Free; + end; + EList.Clear; + enter := false; + if TabStrt then TabStop := TabSave; + if g then + SendMessage(Parent.Handle, WM_ROWCHANG, LVCurItem, 0); +end; +end; + +procedure TListEdit.PostFree; +begin +with LView^ do begin + if Key = 27 then + PostMessage(Handle, WM_JUSTFREE, key, 0); + if Key = 13 then + PostMessage(Handle, WM_EDITFREE, key, 0); + if ((key = 40) and (LView.LVCurItem < LView.LVCount - 1)) or + ((key = 38) and (LView.LVCurItem > 0)) then begin + PostMessage(Handle, WM_EDITFREE, key, 0); + PostMessage(Handle, wm_keydown, Key, 0); + PostMessage(Handle, wm_keyup, Key, 0); + end; +end; +end; + +procedure TListEdit.EDChar; +begin + case key of + 13, + 27, + 38, + 40: PostFree(key); + end; +end; + +procedure TListEdit.EDPres; +begin + case key of + 38, + 40: key := 0; + end; +end; + +procedure TListEdit.EDentr; +begin + PControl(Sender).SelectAll; +end; + +end. diff --git a/Addons/MCKGRushButtonEditor.pas b/Addons/MCKGRushButtonEditor.pas new file mode 100644 index 0000000..5cf1bf8 --- /dev/null +++ b/Addons/MCKGRushButtonEditor.pas @@ -0,0 +1,2570 @@ +unit MCKGRushButtonEditor; + +// file: MCKGRushButtonEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, + {$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; + {$ELSE} + DsgnIntf; + {$ENDIF} + +type + TButtonStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + {$I MCKfakeClasses.inc} + PButtonEditor = ^TButtonEditor; + TButtonEditor = object(TObj) + Form: PControl; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down3: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + DrawFocus: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label25: TKOLLabel; + UpdateSpeed: TKOLComboBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + Control: TKOLGRushButton; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton19: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TButtonStylesProp; + Styles: TKOLGRushButtonStyles; + Component: MCKGRushControls.TKOLGRushButton; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down3Click(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure UpdateSpeedSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawFocusClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton19Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + private + public + end; + +var ButtonEditor: PButtonEditor; + +procedure Register; +procedure NewButtonEditor(var Result: PButtonEditor; Prop: TButtonStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushButtonStyles), nil, '', TButtonStylesProp); +end; + +procedure NewButtonEditor(var Result: PButtonEditor; Prop: TButtonStylesProp); +begin + New(Result, Create); + Result.Form := NewForm(nil, 'ButtonEditor').SetPosition(193, 124).SetClientSize(520, 537); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.CD1.OwnerWindow := Result.Form.Handle; + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 480).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 480).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(401, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(273, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Over state'; + Result.StatesList.Items[3] := 'Down state'; + Result.StatesList.Items[4] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 184).SetSize(249, 345)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 272).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 272).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 248).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 272).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 272).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 296).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 200).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 224).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 224).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label25 := NewLabel(Result.GRushPanel1, 'Update speed:').SetPosition(8, 320).SetSize(97, 17); + Result.Label25.TextAlign := taRight; + Result.Label25.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 104).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 128).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 128).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 152).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 176).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 176).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 272).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 224).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 224).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 272).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 272).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 296).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 272).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton19 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 320).SetSize(41, 17)); + Result.GRushButton19.Font.FontHeight := 8; + Result.GRushButton19.All_BorderRoundWidth := 0; + Result.GRushButton19.All_BorderRoundHeight := 0; + Result.GRushButton19.Down_BorderWidth := 1; + Result.GRushButton19.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 126).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 126).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 174).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 174).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.UpdateSpeed := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 318).SetSize(81, 21); + Result.UpdateSpeed.Font.FontHeight := 8; + Result.UpdateSpeed.Color := clWindow; + Result.UpdateSpeed.Items[0] := 'Immediately'; + Result.UpdateSpeed.Items[1] := 'Very fast'; + Result.UpdateSpeed.Items[2] := 'Fast'; + Result.UpdateSpeed.Items[3] := 'Normal'; + Result.UpdateSpeed.Items[4] := 'Slow'; + Result.UpdateSpeed.Items[5] := 'Very slow'; + Result.UpdateSpeed.CurIndex := 0; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.Dis_ColorText := 8421504; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.Down_ShadowOffset := 1; + Result.AntiAliasing.Dis_ShadowOffset := 1; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.All_ShadowOffset := 0; + Result.DrawFocus := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw focus').SetPosition(128, 8).SetSize(113, 17)); + Result.DrawFocus.Down_ColorFrom := 14798527; + Result.DrawFocus.Down_ColorTo := 16777215; + Result.DrawFocus.All_ColorOuter := 15259342; + Result.DrawFocus.All_ColorShadow := 12632256; + Result.DrawFocus.Over_BorderColor := 8421504; + Result.DrawFocus.Down_BorderWidth := 1; + Result.DrawFocus.All_ShadowOffset := 0; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.Dis_ColorText := 8421504; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.Down_ShadowOffset := 1; + Result.DrawGlyph.Dis_ShadowOffset := 1; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.Dis_ColorText := 8421504; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.Down_ShadowOffset := 1; + Result.DrawText.Dis_ShadowOffset := 1; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.All_ShadowOffset := 0; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(8, 80).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.Dis_ColorText := 8421504; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.Down_ShadowOffset := 1; + Result.WordWrap.Dis_ShadowOffset := 1; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(7, 8).SetSize(249, 169)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 144).SetSize(233, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Caption.Text := 'Button control'; + Result.Control := PGRushControl(NewGRushButton(Result.GRushPanel3, 'Button control').SetPosition(8, 24).SetSize(233, 89)); + Result.Control.Font.FontStyle := []; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 120).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 120).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down3 := PGRushControl(NewGRushButton(Result.UpdateSpeed, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down3.All_BorderRoundWidth := 0; + Result.Down3.All_BorderRoundHeight := 0; + Result.Down3.Down_BorderWidth := 1; + Result.Down3.Dis_BorderWidth := 1; + Result.Down3.Def_ShadowOffset := 0; + Result.Down3.Over_ShadowOffset := 0; + Result.Down3.Down_ShadowOffset := 255; + Result.Down3.Dis_ShadowOffset := 0; + Result.Down3.Over_GlyphItemY := 1; + Result.Down3.Down_GlyphItemY := 2; + Result.Down3.Dis_GlyphItemY := 3; + Result.Down3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down3.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down3.All_GlyphWidth := 12; + Result.Down3.All_GlyphHeight := 12; + Result.Down3.All_GlyphHAlign := haCenter; + Result.Down3.All_Spacing := 0; + Result.Down3.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushButtonStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushButton); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down3.OnClick := Result.Down3Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton19.OnClick := Result.GRushButton19Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.UpdateSpeed.OnSelChange := Result.UpdateSpeedSelChange; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawFocus.OnClick := Result.DrawFocusClick; + Result.DrawFocus.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushImageCollection1.Free; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); + +end; + +procedure TButtonEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TButtonEditor.KOLForm1FormCreate(Sender: PObj); +begin + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + Antialiasing.Checked := Control.All_AntiAliasing; + DrawFocus.Checked := Control.All_DrawFocusRect; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); + UpdateSpeed.CurIndex := Integer(Control.All_UpdateSpeed); +end; + +procedure TButtonEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TButtonEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TButtonEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TButtonEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TButtonEditor.Down3Click(Sender: PObj); +begin + UpdateSpeed.DroppedDown := TRUE; +end; + +procedure TButtonEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TButtonEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TButtonEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TButtonEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TButtonEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Over_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 3: + begin + Control.Down_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 4: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorOuter; + if CD1.Execute then + Control.Over_ColorOuter := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorOuter; + if CD1.Execute then + Control.Down_ColorOuter := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorFrom; + if CD1.Execute then + Control.Over_ColorFrom := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorFrom; + if CD1.Execute then + Control.Down_ColorFrom := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorTo; + if CD1.Execute then + Control.Over_ColorTo := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorTo; + if CD1.Execute then + Control.Down_ColorTo := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_BorderColor; + if CD1.Execute then + Control.Over_BorderColor := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_BorderColor; + if CD1.Execute then + Control.Down_BorderColor := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorText; + if CD1.Execute then + Control.Over_ColorText := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorText; + if CD1.Execute then + Control.Down_ColorText := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorShadow; + if CD1.Execute then + Control.Over_ColorShadow := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorShadow; + if CD1.Execute then + Control.Down_ColorShadow := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Over_ColorOuter; + Col2.Color := Control.Over_ColorFrom; + Col3.Color := Control.Over_ColorTo; + Col4.Color := Control.Over_BorderColor; + Col5.Color := Control.Over_ColorText; + Col6.Color := Control.Over_ColorShadow; + GradStyles.CurIndex := Integer(Control.Over_GradientStyle); + BorderWidth.Text := int2str(Control.Over_BorderWidth); + ShadowOffset.Text := int2str(Control.Over_ShadowOffset); + BorderWi.Text := int2str(Control.Over_BorderRoundWidth); + BorderHe.Text := int2str(Control.Over_BorderRoundHeight); + GlyphX.Text := int2str(Control.Over_GlyphItemX); + GlyphY.Text := int2str(Control.Over_GlyphItemY); + end; + 3: + begin + Col1.Color := Control.Down_ColorOuter; + Col2.Color := Control.Down_ColorFrom; + Col3.Color := Control.Down_ColorTo; + Col4.Color := Control.Down_BorderColor; + Col5.Color := Control.Down_ColorText; + Col6.Color := Control.Down_ColorShadow; + GradStyles.CurIndex := Integer(Control.Down_GradientStyle); + BorderWidth.Text := int2str(Control.Down_BorderWidth); + ShadowOffset.Text := int2str(Control.Down_ShadowOffset); + BorderWi.Text := int2str(Control.Down_BorderRoundWidth); + BorderHe.Text := int2str(Control.Down_BorderRoundHeight); + GlyphX.Text := int2str(Control.Down_GlyphItemX); + GlyphY.Text := int2str(Control.Down_GlyphItemY); + end; + 4: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TButtonEditor.UpdateSpeedSelChange(Sender: PObj); +begin + Control.All_UpdateSpeed := TGRushSpeed(UpdateSpeed.CurIndex); +end; + +procedure TButtonEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.DrawFocusClick(Sender: PObj); +begin + Control.All_DrawFocusRect := DrawFocus.Checked; + Control.Invalidate; +end; + +procedure TButtonEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TButtonEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TButtonEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TButtonEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TButtonEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TButtonEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TButtonEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TButtonEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TButtonEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Over_BorderRoundWidth := Val; + end; + 3: + begin + Control.Down_BorderRoundWidth := Val; + end; + 4: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Over_BorderRoundHeight := Val; + end; + 3: + begin + Control.Down_BorderRoundHeight := Val; + end; + 4: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Over_GlyphItemX := Val; + end; + 3: + begin + Control.Down_GlyphItemX := Val; + end; + 4: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Over_GlyphItemY := Val; + end; + 3: + begin + Control.Down_GlyphItemY := Val; + end; + 4: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Over_ShadowOffset := Val; + end; + 3: + begin + Control.Down_ShadowOffset := Val; + end; + 4: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Over_BorderWidth := Val; + end; + 3: + begin + Control.Down_BorderWidth := Val; + end; + 4: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 1; + Control.All_TextHAlign := haCenter; + TextVert.CurIndex := 1; + Control.All_TextVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '4'; + T.Text := '4'; + R.Text := '-4'; + B.Text := '-4'; + Control.All_ContentOffsets := MakeRect(4, 4, -4, -4); + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton19Click(Sender: PObj); +begin + UpdateSpeed.CurIndex := 2; + Control.All_UpdateSpeed := usFast; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Over_GlyphItemX := 0; + Control.Over_GlyphItemY := 0; + end; + 3: + begin + Control.Down_GlyphItemX := 0; + Control.Down_GlyphItemY := 0; + end; + 4: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TButtonEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := 4; + Control.Def_BorderRoundHeight := 4; + BorderWi.Text := '4'; + BorderHe.Text := '4'; + end; + 2: + begin + Control.Over_BorderRoundWidth := 4; + Control.Over_BorderRoundHeight := 4; + BorderWi.Text := '4'; + BorderHe.Text := '4'; + end; + 3: + begin + Control.Down_BorderRoundWidth := 8; + Control.Down_BorderRoundHeight := 4; + BorderWi.Text := '8'; + BorderHe.Text := '4'; + end; + 4: + begin + Control.Dis_BorderRoundWidth := 5; + Control.Dis_BorderRoundHeight := 5; + BorderWi.Text := '5'; + BorderHe.Text := '5'; + end; + 0: + begin + Control.All_BorderRoundWidth := 4; + Control.All_BorderRoundHeight := 4; + Control.Down_BorderRoundWidth := 8; + Control.Dis_BorderRoundWidth := 5; + Control.Dis_BorderRoundHeight := 5; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Over_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 3: + begin + Control.Down_ShadowOffset := -1; + ShadowOffset.Text := '-1'; + end; + 4: + begin + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '2'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Over_ShadowOffset := 1; + Control.Down_ShadowOffset := -1; + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 2: + begin + Control.Over_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 3: + begin + Control.Down_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 4: + begin + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 0: + begin + Control.Def_BorderWidth := 1; + Control.Over_BorderWidth := 1; + Control.Down_BorderWidth := 2; + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := gsVertical; + GradStyles.CurIndex := 1; + end; + 2: + begin + Control.Over_GradientStyle := gsDoubleVert; + GradStyles.CurIndex := 3; + end; + 3: + begin + Control.Down_GradientStyle := gsDoubleHorz; + GradStyles.CurIndex := 4; + end; + 4: + begin + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 0: + begin + Control.Def_GradientStyle := gsVertical; + Control.Over_GradientStyle := gsDoubleVert; + Control.Down_GradientStyle := gsDoubleHorz; + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Over_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 3: + begin + Control.Down_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 4: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 2: + begin + Control.Over_ColorFrom := $00E1CEBF; + Col2.Color := $00E1CEBF; + end; + 3: + begin + Control.Down_ColorFrom := $00F0FBFF; + Col2.Color := $00F0FBFF; + end; + 4: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := clWhite; + Control.Over_ColorFrom := $00E1CEBF; + Control.Down_ColorFrom := $00F0FBFF; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $00D1BEAF; + Col3.Color := $00D1BEAF; + end; + 2: + begin + Control.Over_ColorTo := clWhite; + Col3.Color := clWhite; + end; + 3: + begin + Control.Down_ColorTo := $00B6BFC6; + Col3.Color := $00B6BFC6; + end; + 4: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $00D1BEAF; + Control.Over_ColorTo := clWhite; + Control.Down_ColorTo := $00B6BFC6; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 2: + begin + Control.Over_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 3: + begin + Control.Down_BorderColor := clGray; + Col4.Color := clGray; + end; + 4: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := $00A4A0A0; + Control.Over_BorderColor := $00A4A0A0; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Over_ColorText := clBlack; + Col5.Color := clBlack; + end; + 3: + begin + Control.Down_ColorText := clBlack; + Col5.Color := clBlack; + end; + 4: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Over_ColorShadow := clGray; + Col5.Color := clGray; + end; + 3: + begin + Control.Down_ColorShadow := clGray; + Col5.Color := clGray; + end; + 4: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TButtonEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TButtonEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + GRushButton19Click(GRushButton19); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := TRUE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + //Control.All_WordWrap := FALSE; + + KOLForm1FormCreate(ButtonEditor); + Control.Invalidate; +end; + +procedure TButtonEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + {try + GlyphBitmap.Free; + finally + GlyphBitmap := nil; + end; } + + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TButtonEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSOver.ColorFrom := Styles.OverPaintState.ColorFrom; + Data.fPSOver.ColorTo := Styles.OverPaintState.ColorTo; + Data.fPSOver.ColorOuter := Styles.OverPaintState.ColorOuter; + Data.fPSOver.ColorText := Styles.OverPaintState.ColorText; + Data.fPSOver.ColorShadow := Styles.OverPaintState.ColorShadow; + Data.fPSOver.BorderColor := Styles.OverPaintState.BorderColor; + Data.fPSOver.BorderRoundWidth := Styles.OverPaintState.BorderRoundWidth; + Data.fPSOver.BorderRoundHeight := Styles.OverPaintState.BorderRoundHeight; + Data.fPSOver.BorderWidth := Styles.OverPaintState.BorderWidth; + Data.fPSOver.GradientStyle := Styles.OverPaintState.GradientStyle; + Data.fPSOver.ShadowOffset := Styles.OverPaintState.ShadowOffset; + Data.fPSOver.GlyphItemX := Styles.OverPaintState.GlyphItemX; + Data.fPSOver.GlyphItemY := Styles.OverPaintState.GlyphItemY; + + Data.fPSDown.ColorFrom := Styles.DownPaintState.ColorFrom; + Data.fPSDown.ColorTo := Styles.DownPaintState.ColorTo; + Data.fPSDown.ColorOuter := Styles.DownPaintState.ColorOuter; + Data.fPSDown.ColorText := Styles.DownPaintState.ColorText; + Data.fPSDown.ColorShadow := Styles.DownPaintState.ColorShadow; + Data.fPSDown.BorderColor := Styles.DownPaintState.BorderColor; + Data.fPSDown.BorderRoundWidth := Styles.DownPaintState.BorderRoundWidth; + Data.fPSDown.BorderRoundHeight := Styles.DownPaintState.BorderRoundHeight; + Data.fPSDown.BorderWidth := Styles.DownPaintState.BorderWidth; + Data.fPSDown.GradientStyle := Styles.DownPaintState.GradientStyle; + Data.fPSDown.ShadowOffset := Styles.DownPaintState.ShadowOffset; + Data.fPSDown.GlyphItemX := Styles.DownPaintState.GlyphItemX; + Data.fPSDown.GlyphItemY := Styles.DownPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := 0;//Styles.SplitterDotsCount; + Data.fCheckMetric := 0;//Styles.CheckMetric; + Data.fColorCheck := 0;//Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := Styles.DrawFocusRect; + Data.fDrawProgress := FALSE;//Styles.DrawProgress; + Data.fDrawProgressRect := FALSE;//Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := FALSE;//Styles.ProgressVertical; + Data.fUpdateSpeed := Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(ButtonEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TButtonEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.OverPaintState.ColorFrom := Data.fPSOver.ColorFrom; + Styles.OverPaintState.ColorTo := Data.fPSOver.ColorTo; + Styles.OverPaintState.ColorOuter := Data.fPSOver.ColorOuter; + Styles.OverPaintState.ColorText := Data.fPSOver.ColorText; + Styles.OverPaintState.ColorShadow := Data.fPSOver.ColorShadow; + Styles.OverPaintState.BorderColor := Data.fPSOver.BorderColor; + Styles.OverPaintState.BorderRoundWidth := Data.fPSOver.BorderRoundWidth; + Styles.OverPaintState.BorderRoundHeight := Data.fPSOver.BorderRoundHeight; + Styles.OverPaintState.BorderWidth := Data.fPSOver.BorderWidth; + Styles.OverPaintState.GradientStyle := Data.fPSOver.GradientStyle; + Styles.OverPaintState.ShadowOffset := Data.fPSOver.ShadowOffset; + Styles.OverPaintState.GlyphItemX := Data.fPSOver.GlyphItemX; + Styles.OverPaintState.GlyphItemY := Data.fPSOver.GlyphItemY; + + Styles.DownPaintState.ColorFrom := Data.fPSDown.ColorFrom; + Styles.DownPaintState.ColorTo := Data.fPSDown.ColorTo; + Styles.DownPaintState.ColorOuter := Data.fPSDown.ColorOuter; + Styles.DownPaintState.ColorText := Data.fPSDown.ColorText; + Styles.DownPaintState.ColorShadow := Data.fPSDown.ColorShadow; + Styles.DownPaintState.BorderColor := Data.fPSDown.BorderColor; + Styles.DownPaintState.BorderRoundWidth := Data.fPSDown.BorderRoundWidth; + Styles.DownPaintState.BorderRoundHeight := Data.fPSDown.BorderRoundHeight; + Styles.DownPaintState.BorderWidth := Data.fPSDown.BorderWidth; + Styles.DownPaintState.GradientStyle := Data.fPSDown.GradientStyle; + Styles.DownPaintState.ShadowOffset := Data.fPSDown.ShadowOffset; + Styles.DownPaintState.GlyphItemX := Data.fPSDown.GlyphItemX; + Styles.DownPaintState.GlyphItemY := Data.fPSDown.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.DrawFocusRect := Data.fDrawFocusRect; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.UpdateSpeed := Data.fUpdateSpeed; + Styles.Spacing := Data.fSpacing; + + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TButtonEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TButtonEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TButtonEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TButtonEditor.WordWrapClick(Sender: PObj); +begin +end; + + + + + + + + + +function TButtonStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TButtonStylesProp.Edit; +var Styles: TKOLGRushButtonStyles; +begin + Styles := TKOLGRushButtonStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushButtonStyles) then exit; + + ButtonEditor := nil; + AppletTerminated := FALSE; + try + NewButtonEditor(ButtonEditor, Self); + ButtonEditor.ActiveWindow := GetActiveWindow; + ButtonEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + +end. + diff --git a/Addons/MCKGRushCheckBoxEditor.pas b/Addons/MCKGRushCheckBoxEditor.pas new file mode 100644 index 0000000..1299178 --- /dev/null +++ b/Addons/MCKGRushCheckBoxEditor.pas @@ -0,0 +1,2620 @@ +unit MCKGRushCheckBoxEditor; + +// file: MCKGRushCheckBoxEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, +{$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; +{$ELSE} + DsgnIntf; +{$ENDIF} + +type + TCheckBoxStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + +{$I MCKfakeClasses.inc} + PCheckBoxEditor = ^TCheckBoxEditor; + TCheckBoxEditor = object(TObj) + Form: PControl; + KOLProject1: TKOLProject; + KOLForm1: TKOLForm; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down3: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + DrawFocus: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label25: TKOLLabel; + UpdateSpeed: TKOLComboBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton19: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + Control: TKOLGRushCheckBox; + Label32: TKOLLabel; + ColorCheck: TKOLLabel; + GRushButton21: TKOLGRushButton; + Label33: TKOLLabel; + CheckMetric: TKOLEditBox; + GRushButton22: TKOLGRushButton; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TCheckBoxStylesProp; + Styles: TKOLGRushCheckBoxStyles; + Component: MCKGRushControls.TKOLGRushCheckBox; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down3Click(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure UpdateSpeedSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawFocusClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton19Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + procedure CheckMetricLeave(Sender: PObj); + procedure GRushButton22Click(Sender: PObj); + procedure ColorCheckClick(Sender: PObj); + procedure GRushButton21Click(Sender: PObj); + private + public + end; + +var CheckBoxEditor: PCheckBoxEditor; + +procedure Register; +procedure NewCheckBoxEditor(var Result: PCheckBoxEditor; Prop: TCheckBoxStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushCheckBoxStyles), nil, '', TCheckBoxStylesProp); +end; + +procedure NewCheckBoxEditor(var Result: PCheckBoxEditor; Prop: TCheckBoxStylesProp); +begin + + New(Result, Create); + Result.Form := NewForm(nil, 'CheckBoxEditor').SetPosition(221, 110).SetClientSize(520, 561); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 504).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 504).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(401, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(273, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Over state'; + Result.StatesList.Items[3] := 'Down state'; + Result.StatesList.Items[4] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 160).SetSize(249, 393)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.ColorCheck := NewLabel(Result.GRushPanel1, '').SetPosition(128, 104).SetSize(49, 17); + Result.ColorCheck.Color := clSilver; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 320).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 320).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 296).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 320).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 320).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 344).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 248).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label25 := NewLabel(Result.GRushPanel1, 'Update speed:').SetPosition(8, 368).SetSize(97, 17); + Result.Label25.TextAlign := taRight; + Result.Label25.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 152).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 176).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 176).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 200).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 224).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 224).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.Label32 := NewLabel(Result.GRushPanel1, 'Check color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label32.TextAlign := taRight; + Result.Label32.Color := $E8D6CE; + Result.Label33 := NewLabel(Result.GRushPanel1, 'Size of check:').SetPosition(8, 128).SetSize(97, 17); + Result.Label33.TextAlign := taRight; + Result.Label33.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 320).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.CheckMetric := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 128).SetSize(81, 17); + Result.CheckMetric.Ctl3D := False; + Result.CheckMetric.Font.FontHeight := 8; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 272).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 272).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 320).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 320).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 344).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 320).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 344).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton19 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 368).SetSize(41, 17)); + Result.GRushButton19.Font.FontHeight := 8; + Result.GRushButton19.All_BorderRoundWidth := 0; + Result.GRushButton19.All_BorderRoundHeight := 0; + Result.GRushButton19.Down_BorderWidth := 1; + Result.GRushButton19.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton21 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton21.Font.FontHeight := 8; + Result.GRushButton21.All_BorderRoundWidth := 0; + Result.GRushButton21.All_BorderRoundHeight := 0; + Result.GRushButton21.Down_BorderWidth := 1; + Result.GRushButton21.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton22 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton22.Font.FontHeight := 8; + Result.GRushButton22.All_BorderRoundWidth := 0; + Result.GRushButton22.All_BorderRoundHeight := 0; + Result.GRushButton22.Down_BorderWidth := 1; + Result.GRushButton22.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 174).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 174).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 222).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 222).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.UpdateSpeed := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 366).SetSize(81, 21); + Result.UpdateSpeed.Font.FontHeight := 8; + Result.UpdateSpeed.Color := clWindow; + Result.UpdateSpeed.Items[0] := 'Immediately'; + Result.UpdateSpeed.Items[1] := 'Very fast'; + Result.UpdateSpeed.Items[2] := 'Fast'; + Result.UpdateSpeed.Items[3] := 'Normal'; + Result.UpdateSpeed.Items[4] := 'Slow'; + Result.UpdateSpeed.Items[5] := 'Very slow'; + Result.UpdateSpeed.CurIndex := 0; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.All_ShadowOffset := 0; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.All_ShadowOffset := 0; + Result.DrawFocus := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw focus').SetPosition(128, 8).SetSize(113, 17)); + Result.DrawFocus.Down_ColorFrom := 14798527; + Result.DrawFocus.Down_ColorTo := 16777215; + Result.DrawFocus.All_ColorOuter := 15259342; + Result.DrawFocus.All_ColorShadow := 12632256; + Result.DrawFocus.Over_BorderColor := 8421504; + Result.DrawFocus.Down_BorderWidth := 1; + Result.DrawFocus.All_ShadowOffset := 0; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.All_ShadowOffset := 0; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.All_ShadowOffset := 0; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.All_ShadowOffset := 0; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(8, 80).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.All_ShadowOffset := 0; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(7, 8).SetSize(249, 145)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 120).SetSize(233, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Caption.Text := 'Button control'; + Result.Control := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'CheckBox1').SetPosition(8, 24).SetSize(233, 65)); + Result.Control.DoubleBuffered := True; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 96).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 96).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down3 := PGRushControl(NewGRushButton(Result.UpdateSpeed, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down3.All_BorderRoundWidth := 0; + Result.Down3.All_BorderRoundHeight := 0; + Result.Down3.Down_BorderWidth := 1; + Result.Down3.Dis_BorderWidth := 1; + Result.Down3.Def_ShadowOffset := 0; + Result.Down3.Over_ShadowOffset := 0; + Result.Down3.Down_ShadowOffset := 255; + Result.Down3.Dis_ShadowOffset := 0; + Result.Down3.Over_GlyphItemY := 1; + Result.Down3.Down_GlyphItemY := 2; + Result.Down3.Dis_GlyphItemY := 3; + Result.Down3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down3.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down3.All_GlyphWidth := 12; + Result.Down3.All_GlyphHeight := 12; + Result.Down3.All_GlyphHAlign := haCenter; + Result.Down3.All_Spacing := 0; + Result.Down3.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushCheckBoxStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushCheckBox); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.ColorCheck.OnClick := Result.ColorCheckClick; + Result.ColorCheck.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.CheckMetric.Color := clWindow; + Result.CheckMetric.OnEnter := Result.BorderWiEnter; + Result.CheckMetric.OnLeave := Result.CheckMetricLeave; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down3.OnClick := Result.Down3Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton19.OnClick := Result.GRushButton19Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushImageCollection1.Free; + Result.GRushButton21.OnClick := Result.GRushButton21Click; + Result.GRushButton22.OnClick := Result.GRushButton22Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.UpdateSpeed.OnSelChange := Result.UpdateSpeedSelChange; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawFocus.OnClick := Result.DrawFocusClick; + Result.DrawFocus.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); +end; + +procedure TCheckBoxEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TCheckBoxEditor.KOLForm1FormCreate(Sender: PObj); +begin + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + Antialiasing.Checked := Control.All_AntiAliasing; + DrawFocus.Checked := Control.All_DrawFocusRect; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); + UpdateSpeed.CurIndex := Integer(Control.All_UpdateSpeed); + CheckMetric.Caption := int2str(Control.All_CheckMetric); + ColorCheck.Color := Control.All_ColorCheck; +end; + +procedure TCheckBoxEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TCheckBoxEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Down3Click(Sender: PObj); +begin + UpdateSpeed.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TCheckBoxEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Over_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 3: + begin + Control.Down_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 4: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorOuter; + if CD1.Execute then + Control.Over_ColorOuter := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorOuter; + if CD1.Execute then + Control.Down_ColorOuter := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorFrom; + if CD1.Execute then + Control.Over_ColorFrom := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorFrom; + if CD1.Execute then + Control.Down_ColorFrom := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorTo; + if CD1.Execute then + Control.Over_ColorTo := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorTo; + if CD1.Execute then + Control.Down_ColorTo := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_BorderColor; + if CD1.Execute then + Control.Over_BorderColor := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_BorderColor; + if CD1.Execute then + Control.Down_BorderColor := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorText; + if CD1.Execute then + Control.Over_ColorText := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorText; + if CD1.Execute then + Control.Down_ColorText := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorShadow; + if CD1.Execute then + Control.Over_ColorShadow := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorShadow; + if CD1.Execute then + Control.Down_ColorShadow := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Over_ColorOuter; + Col2.Color := Control.Over_ColorFrom; + Col3.Color := Control.Over_ColorTo; + Col4.Color := Control.Over_BorderColor; + Col5.Color := Control.Over_ColorText; + Col6.Color := Control.Over_ColorShadow; + GradStyles.CurIndex := Integer(Control.Over_GradientStyle); + BorderWidth.Text := int2str(Control.Over_BorderWidth); + ShadowOffset.Text := int2str(Control.Over_ShadowOffset); + BorderWi.Text := int2str(Control.Over_BorderRoundWidth); + BorderHe.Text := int2str(Control.Over_BorderRoundHeight); + GlyphX.Text := int2str(Control.Over_GlyphItemX); + GlyphY.Text := int2str(Control.Over_GlyphItemY); + end; + 3: + begin + Col1.Color := Control.Down_ColorOuter; + Col2.Color := Control.Down_ColorFrom; + Col3.Color := Control.Down_ColorTo; + Col4.Color := Control.Down_BorderColor; + Col5.Color := Control.Down_ColorText; + Col6.Color := Control.Down_ColorShadow; + GradStyles.CurIndex := Integer(Control.Down_GradientStyle); + BorderWidth.Text := int2str(Control.Down_BorderWidth); + ShadowOffset.Text := int2str(Control.Down_ShadowOffset); + BorderWi.Text := int2str(Control.Down_BorderRoundWidth); + BorderHe.Text := int2str(Control.Down_BorderRoundHeight); + GlyphX.Text := int2str(Control.Down_GlyphItemX); + GlyphY.Text := int2str(Control.Down_GlyphItemY); + end; + 4: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TCheckBoxEditor.UpdateSpeedSelChange(Sender: PObj); +begin + Control.All_UpdateSpeed := TGRushSpeed(UpdateSpeed.CurIndex); +end; + +procedure TCheckBoxEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.DrawFocusClick(Sender: PObj); +begin + Control.All_DrawFocusRect := DrawFocus.Checked; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TCheckBoxEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TCheckBoxEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TCheckBoxEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TCheckBoxEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Over_BorderRoundWidth := Val; + end; + 3: + begin + Control.Down_BorderRoundWidth := Val; + end; + 4: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Over_BorderRoundHeight := Val; + end; + 3: + begin + Control.Down_BorderRoundHeight := Val; + end; + 4: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Over_GlyphItemX := Val; + end; + 3: + begin + Control.Down_GlyphItemX := Val; + end; + 4: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Over_GlyphItemY := Val; + end; + 3: + begin + Control.Down_GlyphItemY := Val; + end; + 4: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Over_ShadowOffset := Val; + end; + 3: + begin + Control.Down_ShadowOffset := Val; + end; + 4: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Over_BorderWidth := Val; + end; + 3: + begin + Control.Down_BorderWidth := Val; + end; + 4: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 0; + Control.All_TextHAlign := haLeft; + TextVert.CurIndex := 1; + Control.All_TextVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '19'; + T.Text := '1'; + R.Text := '-1'; + B.Text := '-1'; + Control.All_ContentOffsets := MakeRect(19, 1, -1, -1); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton19Click(Sender: PObj); +begin + UpdateSpeed.CurIndex := 2; + Control.All_UpdateSpeed := usFast; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Over_GlyphItemX := 0; + Control.Over_GlyphItemY := 0; + end; + 3: + begin + Control.Down_GlyphItemX := 0; + Control.Down_GlyphItemY := 0; + end; + 4: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TCheckBoxEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := 0; + Control.Def_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 2: + begin + Control.Over_BorderRoundWidth := 0; + Control.Over_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 3: + begin + Control.Down_BorderRoundWidth := 0; + Control.Down_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 4: + begin + Control.Dis_BorderRoundWidth := 0; + Control.Dis_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 0: + begin + Control.All_BorderRoundWidth := 0; + Control.All_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Over_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 3: + begin + Control.Down_ShadowOffset := -1; + ShadowOffset.Text := '-1'; + end; + 4: + begin + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '2'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Over_ShadowOffset := 1; + Control.Down_ShadowOffset := -1; + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 2: + begin + Control.Over_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 3: + begin + Control.Down_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 4: + begin + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 0: + begin + Control.Def_BorderWidth := 1; + Control.Over_BorderWidth := 1; + Control.Down_BorderWidth := 2; + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 2: + begin + Control.Over_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 3: + begin + Control.Down_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 4: + begin + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 0: + begin + Control.All_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Over_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 3: + begin + Control.Down_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 4: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 2: + begin + Control.Over_ColorFrom := $00E1CEBF; + Col2.Color := $00E1CEBF; + end; + 3: + begin + Control.Down_ColorFrom := $00F0FBFF; + Col2.Color := $00F0FBFF; + end; + 4: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := clWhite; + Control.Over_ColorFrom := $00E1CEBF; + Control.Down_ColorFrom := $00F0FBFF; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $00D1BEAF; + Col3.Color := $00D1BEAF; + end; + 2: + begin + Control.Over_ColorTo := clWhite; + Col3.Color := clWhite; + end; + 3: + begin + Control.Down_ColorTo := $00B6BFC6; + Col3.Color := $00B6BFC6; + end; + 4: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $00D1BEAF; + Control.Over_ColorTo := clWhite; + Control.Down_ColorTo := $00B6BFC6; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := clGray; + Col4.Color := clGray; + end; + 2: + begin + Control.Over_BorderColor := $404040; + Col4.Color := $404040; + end; + 3: + begin + Control.Down_BorderColor := clGray; + Col4.Color := clGray; + end; + 4: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := clGray; + Control.Over_BorderColor := $404040; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Over_ColorText := clBlack; + Col5.Color := clBlack; + end; + 3: + begin + Control.Down_ColorText := clBlack; + Col5.Color := clBlack; + end; + 4: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Over_ColorShadow := clGray; + Col5.Color := clGray; + end; + 3: + begin + Control.Down_ColorShadow := clGray; + Col5.Color := clGray; + end; + 4: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TCheckBoxEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + GRushButton19Click(GRushButton19); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := TRUE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + KOLForm1FormCreate(CheckBoxEditor); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TCheckBoxEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSOver.ColorFrom := Styles.OverPaintState.ColorFrom; + Data.fPSOver.ColorTo := Styles.OverPaintState.ColorTo; + Data.fPSOver.ColorOuter := Styles.OverPaintState.ColorOuter; + Data.fPSOver.ColorText := Styles.OverPaintState.ColorText; + Data.fPSOver.ColorShadow := Styles.OverPaintState.ColorShadow; + Data.fPSOver.BorderColor := Styles.OverPaintState.BorderColor; + Data.fPSOver.BorderRoundWidth := Styles.OverPaintState.BorderRoundWidth; + Data.fPSOver.BorderRoundHeight := Styles.OverPaintState.BorderRoundHeight; + Data.fPSOver.BorderWidth := Styles.OverPaintState.BorderWidth; + Data.fPSOver.GradientStyle := Styles.OverPaintState.GradientStyle; + Data.fPSOver.ShadowOffset := Styles.OverPaintState.ShadowOffset; + Data.fPSOver.GlyphItemX := Styles.OverPaintState.GlyphItemX; + Data.fPSOver.GlyphItemY := Styles.OverPaintState.GlyphItemY; + + Data.fPSDown.ColorFrom := Styles.DownPaintState.ColorFrom; + Data.fPSDown.ColorTo := Styles.DownPaintState.ColorTo; + Data.fPSDown.ColorOuter := Styles.DownPaintState.ColorOuter; + Data.fPSDown.ColorText := Styles.DownPaintState.ColorText; + Data.fPSDown.ColorShadow := Styles.DownPaintState.ColorShadow; + Data.fPSDown.BorderColor := Styles.DownPaintState.BorderColor; + Data.fPSDown.BorderRoundWidth := Styles.DownPaintState.BorderRoundWidth; + Data.fPSDown.BorderRoundHeight := Styles.DownPaintState.BorderRoundHeight; + Data.fPSDown.BorderWidth := Styles.DownPaintState.BorderWidth; + Data.fPSDown.GradientStyle := Styles.DownPaintState.GradientStyle; + Data.fPSDown.ShadowOffset := Styles.DownPaintState.ShadowOffset; + Data.fPSDown.GlyphItemX := Styles.DownPaintState.GlyphItemX; + Data.fPSDown.GlyphItemY := Styles.DownPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := 0;//Styles.SplitterDotsCount; + Data.fCheckMetric := Styles.CheckMetric; + Data.fColorCheck := Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := Styles.DrawFocusRect; + Data.fDrawProgress := FALSE;//Styles.DrawProgress; + Data.fDrawProgressRect := FALSE;//Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := FALSE;//Styles.ProgressVertical; + Data.fUpdateSpeed := Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(CheckBoxEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.ColorCheck := Data.fColorCheck; + Styles.CheckMetric := Data.fCheckMetric; + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.OverPaintState.ColorFrom := Data.fPSOver.ColorFrom; + Styles.OverPaintState.ColorTo := Data.fPSOver.ColorTo; + Styles.OverPaintState.ColorOuter := Data.fPSOver.ColorOuter; + Styles.OverPaintState.ColorText := Data.fPSOver.ColorText; + Styles.OverPaintState.ColorShadow := Data.fPSOver.ColorShadow; + Styles.OverPaintState.BorderColor := Data.fPSOver.BorderColor; + Styles.OverPaintState.BorderRoundWidth := Data.fPSOver.BorderRoundWidth; + Styles.OverPaintState.BorderRoundHeight := Data.fPSOver.BorderRoundHeight; + Styles.OverPaintState.BorderWidth := Data.fPSOver.BorderWidth; + Styles.OverPaintState.GradientStyle := Data.fPSOver.GradientStyle; + Styles.OverPaintState.ShadowOffset := Data.fPSOver.ShadowOffset; + Styles.OverPaintState.GlyphItemX := Data.fPSOver.GlyphItemX; + Styles.OverPaintState.GlyphItemY := Data.fPSOver.GlyphItemY; + + Styles.DownPaintState.ColorFrom := Data.fPSDown.ColorFrom; + Styles.DownPaintState.ColorTo := Data.fPSDown.ColorTo; + Styles.DownPaintState.ColorOuter := Data.fPSDown.ColorOuter; + Styles.DownPaintState.ColorText := Data.fPSDown.ColorText; + Styles.DownPaintState.ColorShadow := Data.fPSDown.ColorShadow; + Styles.DownPaintState.BorderColor := Data.fPSDown.BorderColor; + Styles.DownPaintState.BorderRoundWidth := Data.fPSDown.BorderRoundWidth; + Styles.DownPaintState.BorderRoundHeight := Data.fPSDown.BorderRoundHeight; + Styles.DownPaintState.BorderWidth := Data.fPSDown.BorderWidth; + Styles.DownPaintState.GradientStyle := Data.fPSDown.GradientStyle; + Styles.DownPaintState.ShadowOffset := Data.fPSDown.ShadowOffset; + Styles.DownPaintState.GlyphItemX := Data.fPSDown.GlyphItemX; + Styles.DownPaintState.GlyphItemY := Data.fPSDown.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.DrawFocusRect := Data.fDrawFocusRect; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.UpdateSpeed := Data.fUpdateSpeed; + Styles.Spacing := Data.fSpacing; + + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TCheckBoxEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TCheckBoxEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TCheckBoxEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TCheckBoxEditor.WordWrapClick(Sender: PObj); +begin +end; + +procedure TCheckBoxEditor.CheckMetricLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_CheckMetric := Val; + L.Text := int2str(Control.All_ContentOffsets.Left); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton22Click(Sender: PObj); +begin + Control.All_CheckMetric := 13; + CheckMetric.Caption := '13'; + L.Text := int2str(Control.All_ContentOffsets.Left); + Control.Invalidate; +end; + +procedure TCheckBoxEditor.ColorCheckClick(Sender: PObj); +begin + CD1.Color := Control.All_ColorCheck; + if CD1.Execute then + Control.All_ColorCheck := CD1.Color; + Control.Invalidate; +end; + +procedure TCheckBoxEditor.GRushButton21Click(Sender: PObj); +begin + ColorCheck.Color := $F3706C; + Control.All_ColorCheck := $F3706C; +end; + + + +function TCheckBoxStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TCheckBoxStylesProp.Edit; +var Styles: TKOLGRushCheckBoxStyles; +begin + Styles := TKOLGRushCheckBoxStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushCheckBoxStyles) then exit; + + CheckBoxEditor := nil; + AppletTerminated := FALSE; + try + NewCheckBoxEditor(CheckBoxEditor, Self); + CheckBoxEditor.ActiveWindow := GetActiveWindow; + CheckBoxEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + +end. + diff --git a/Addons/MCKGRushControls.pas b/Addons/MCKGRushControls.pas new file mode 100644 index 0000000..d775380 --- /dev/null +++ b/Addons/MCKGRushControls.pas @@ -0,0 +1,3110 @@ +unit MCKGRushControls; + +// file: MCKGRushControls.pas +// file version: 0.35 +// last modified: 14.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + Classes, + Controls, + KOL, + KOLGRushControls, + mirror, + mckCtrls, + Graphics, + Forms, + SysUtils, + mckObjs, + dialogs, + {$IFDEF _D6orHigher} + DesignIntf, + DesignEditors, + DesignConst, + Variants + {$ELSE} + DsgnIntf + {$ENDIF}; + +{$R *.res} + +const + clMoneyGreen = TColor($C0DCC0); + clSkyBlue = TColor($F0CAA6); + clCream = TColor($F0FBFF); + clMedGray = TColor($A4A0A0); + +type + TKOLCustomControl_ = class ( TKOLCustomControl ) end; + TKOLPaintState = packed class ( TPersistent ) + protected + fOwner: TComponent; + fColorFrom: TColor; + fColorTo: TColor; + fColorOuter: TColor; + fColorText: TColor; + fColorShadow: TColor; + fBorderColor: TColor; + fBorderRoundWidth: DWORD; + fBorderRoundHeight: DWORD; + fBorderWidth: DWORD; + fGradientStyle: TGRushGradientStyle; + fShadowOffset: Integer; + fGlyphItemX: DWORD; + fGlyphItemY: DWORD; + public + procedure Assign(Source: TPersistent); override; + constructor Create (aOwner: TComponent); + procedure Change; + procedure SetColorFrom( Value: TColor ); + procedure SetColorTo( Value: TColor ); + procedure SetColorOuter( Value: TColor ); + procedure SetColorText( Value: TColor ); + procedure SetColorShadow( Value: TColor ); + procedure SetBorderColor( Value: TColor ); + procedure SetBorderRoundWidth( Value: DWORD ); + procedure SetBorderRoundHeight( Value: DWORD ); + procedure SetBorderWidth( Value: DWORD ); + procedure SetGradientStyle( Value: TGRushGradientStyle ); + procedure SetShadowOffset( Value: Integer ); + procedure SetGlyphItemX( Value: DWORD ); + procedure SetGlyphItemY( Value: DWORD ); + published + property ColorFrom: TColor read fColorFrom write SetColorFrom; + property ColorTo: TColor read fColorTo write SetColorTo; + property ColorOuter: TColor read fColorOuter write SetColorOuter; + property ColorText: TColor read fColorText write SetColorText; + property ColorShadow: TColor read fColorShadow write SetColorShadow; + property BorderColor: TColor read fBorderColor write SetBorderColor; + property BorderRoundWidth: DWORD read fBorderRoundWidth write SetBorderRoundWidth; + property BorderRoundHeight: DWORD read fBorderRoundHeight write SetBorderRoundHeight; + property BorderWidth: DWORD read fBorderWidth write SetBorderWidth; + property GradientStyle: TGRushGradientStyle read fGradientStyle write SetGradientStyle; + property ShadowOffset: Integer read fShadowOffset write SetShadowOffset; + property GlyphItemX: DWORD read fGlyphItemX write SetGlyphItemX default 0; + property GlyphItemY: DWORD read fGlyphItemY write SetGlyphItemY default 0; + end; + +//************************************************************ + + TKOLRect = class ( TPersistent ) + protected + fOwner: TComponent; + fLeft: Integer; + fTop: Integer; + fRight: Integer; + fBottom: Integer; + public + procedure Assign(Source: TPersistent); override; + constructor Create (aOwner: TComponent; const aRect: TRect); + procedure Change; + procedure SetLeft( Value: Integer ); + procedure SetTop( Value: Integer ); + procedure SetRight( Value: Integer ); + procedure SetBottom( Value: Integer ); + published + property Left: Integer read fLeft write SetLeft; + property Top: Integer read fTop write SetTop; + property Right: Integer read fRight write SetRight; + property Bottom: Integer read fBottom write SetBottom; + end; + +//************************************************************ + + TKOLGRushStyles = class ( TPersistent ) + protected + fOwner: TComponent; + fPSDef: TKOLPaintState; + fPSOver: TKOLPaintState; + fPSDown: TKOLPaintState; + fPSDis: TKOLPaintState; + fContentOffsets: TKOLRect; + fGlyphWidth: DWORD; + fGlyphHeight: DWORD; + fSplitterDotsCount: DWORD; + fCheckMetric: DWORD; + fColorCheck: TColor; + fGlyphVAlign: KOL.TVerticalAlign; + fGlyphHAlign: TGRushHAlign; + fTextVAlign: KOL.TVerticalAlign; + fTextHAlign: TGRushHAlign; + fDrawGlyph: Boolean; + fDrawText: Boolean; + fDrawFocusRect: Boolean; + fDrawProgress: Boolean; + fDrawProgressRect: Boolean; + fGlyphAttached: Boolean; + fCropTopFirst: Boolean; + fAntiAliasing: Boolean; + fProgressVertical: Boolean; + fUpdateSpeed: TGRushSpeed; + fSpacing: DWORD; + public + procedure Assign(Source: TPersistent); override; + constructor Create (aOwner: TComponent); + destructor Destroy; override; + property Owner: TComponent read fOwner; + procedure Change; + procedure SetGlyphWidth ( Value: DWORD ); + procedure SetGlyphHeight ( Value: DWORD ); + procedure SetSplitterDotsCount ( Value: DWORD ); + procedure SetCheckMetric ( Value: DWORD ); + procedure SetColorCheck ( Value: TColor ); + procedure SetGlyphVAlign ( Value: KOL.TVerticalAlign ); + procedure SetGlyphHAlign ( Value: TGRushHAlign ); + procedure SetTextVAlign ( Value: KOL.TVerticalAlign ); + procedure SetTextHAlign ( Value: TGRushHAlign ); + procedure SetDrawGlyph ( Value: Boolean ); + procedure SetDrawText ( Value: Boolean ); + procedure SetDrawFocusRect ( Value: Boolean ); + procedure SetDrawProgress ( Value: Boolean ); + procedure SetDrawProgressRect ( Value: Boolean ); + procedure SetGlyphAttached ( Value: Boolean ); + procedure SetCropTopFirst ( Value: Boolean ); + procedure SetAntiAliasing ( Value: Boolean ); + procedure SetProgressVertical ( Value: Boolean ); + procedure SetUpdateSpeed ( Value: TGRushSpeed ); + procedure SetSpacing ( Value: DWORD ); + + procedure SetUpProgressVertical ( Value: Boolean ); + procedure SetUpSplitterAlign ( Value: Boolean ); + end; + +//************************************************************ + + TKOLGRushButtonStyles = class (TKOLGRushStyles) + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} property OverPaintState: TKOLPaintState read fPSOver write fPSOver; + {-} property DownPaintState: TKOLPaintState read fPSDown write fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + //property CheckMetric: DWORD read fCheckMetric write SetCheckMetric; + //property ColorCheck: TColor read fColorCheck write SetColorCheck; + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaCenter; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haCenter; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect default TRUE; + //property DrawProgress: Boolean read fDrawProgress write SetDrawProgress; + //property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + //property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical; + property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed default usFast; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + end; + +//************************************************************ + + TKOLGRushPanelStyles = class (TKOLGRushStyles) + public + constructor Create (aOwner: TComponent); + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} //property OverPaintState: TKOLPaintState read fPSOver; + {-} //property DownPaintState: TKOLPaintState read fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + //property CheckMetric: DWORD read fCheckMetric write SetCheckMetric; + //property ColorCheck: TColor read fColorCheck write SetColorCheck; + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaTop; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haCenter; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + //property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect; + //property DrawProgress: Boolean read fDrawProgress write SetDrawProgress; + //property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + //property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical; + //property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + end; + +//************************************************************ + + TKOLGRushCheckBoxStyles = class (TKOLGRushStyles) + public + constructor Create (aOwner: TComponent); + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} property OverPaintState: TKOLPaintState read fPSOver write fPSOver; + {-} property DownPaintState: TKOLPaintState read fPSDown write fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + property CheckMetric: DWORD read fCheckMetric write SetCheckMetric default 13; + property ColorCheck: TColor read fColorCheck write SetColorCheck default integer($F3706C); + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaCenter; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haLeft; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect default TRUE; + //property DrawProgress: Boolean read fDrawProgress write SetDrawProgress; + //property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + //property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical; + property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed default usFast; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + end; + +//************************************************************ + + TKOLGRushRadioBoxStyles = class (TKOLGRushStyles) + public + constructor Create (aOwner: TComponent); + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} property OverPaintState: TKOLPaintState read fPSOver write fPSOver; + {-} property DownPaintState: TKOLPaintState read fPSDown write fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + property CheckMetric: DWORD read fCheckMetric write SetCheckMetric default 13; + property ColorCheck: TColor read fColorCheck write SetColorCheck default integer($F3706C); + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaCenter; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haLeft; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect default TRUE; + //property DrawProgress: Boolean read fDrawProgress write SetDrawProgress; + //property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + //property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical; + property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed default usFast; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + end; + +//************************************************************ + + TKOLGRushSplitterStyles = class (TKOLGRushStyles) + public + constructor Create (aOwner: TComponent); + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} property OverPaintState: TKOLPaintState read fPSOver write fPSOver; + {-} property DownPaintState: TKOLPaintState read fPSDown write fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + //property CheckMetric: DWORD read fCheckMetric write SetCheckMetric; + //property ColorCheck: TColor read fColorCheck write SetColorCheck; + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaCenter; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haCenter; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + //property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect; + //property DrawProgress: Boolean read fDrawProgress write SetDrawProgress; + //property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + //property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical; + property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed default usVeryFast; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + {-} property SplitterDotsCount: DWORD read fSplitterDotsCount write SetSplitterDotsCount default 16; + end; + +//************************************************************ + + TKOLGRushProgressBarStyles = class (TKOLGRushStyles) + public + constructor Create (aOwner: TComponent); + published + {-} property DefPaintState: TKOLPaintState read fPSDef write fPSDef; + {-} //property OverPaintState: TKOLPaintState read fPSOver; + {-} //property DownPaintState: TKOLPaintState read fPSDown; + {-} property DisPaintState: TKOLPaintState read fPSDis write fPSDis; + {-} property ContentOffsets: TKOLRect read fContentOffsets write fContentOffsets; + {-} property GlyphWidth: DWORD read fGlyphWidth write SetGlyphWidth default 0; + {-} property GlyphHeight: DWORD read fGlyphHeight write SetGlyphHeight default 0; + //property CheckMetric: DWORD read fCheckMetric write SetCheckMetric; + //property ColorCheck: TColor read fColorCheck write SetColorCheck; + {-} property GlyphVAlign: KOL.TVerticalAlign read fGlyphVAlign write SetGlyphVAlign default KOL.vaCenter; + {-} property GlyphHAlign: TGRushHAlign read fGlyphHAlign write SetGlyphHAlign default haLeft; + {-} property TextVAlign: KOL.TVerticalAlign read fTextVAlign write SetTextVAlign default KOL.vaCenter; + {-} property TextHAlign: TGRushHAlign read fTextHAlign write SetTextHAlign default haCenter; + {-} property DrawGlyph: Boolean read fDrawGlyph write SetDrawGlyph default TRUE; + {-} property DrawText: Boolean read fDrawText write SetDrawText default TRUE; + //property DrawFocusRect: Boolean read fDrawFocusRect write SetDrawFocusRect; + property DrawProgress: Boolean read fDrawProgress write SetDrawProgress default TRUE; + property DrawProgressRect: Boolean read fDrawProgressRect write SetDrawProgressRect default TRUE; + {-} property GlyphAttached: Boolean read fGlyphAttached write SetGlyphAttached default FALSE; + {-} property CropTopFirst: Boolean read fCropTopFirst write SetCropTopFirst default TRUE; + {-} property AntiAliasing: Boolean read fAntiAliasing write SetAntiAliasing default TRUE; + property ProgressVertical: Boolean read fProgressVertical write SetProgressVertical default FALSE; + //property UpdateSpeed: TGRushSpeed read fUpdateSpeed write SetUpdateSpeed; + {-} property Spacing: DWORD read fSpacing write SetSpacing default 5; + end; + +//************************************************************ + + TKOLGRushImageCollectionImageType = (None, BMP_GIF_JPG, PNG); + TKOLGRushImageCollection = class (TKOLObj) + protected + fImageType: TKOLGRushImageCollectionImageType; + fItemWidth: DWORD; + fItemHeight: DWORD; + fDataStream: TMemoryStream; + function GetResourceName: String; + function GetResourceFileName: String; + procedure SetImageType(Value: TKOLGRushImageCollectionImageType); + procedure SetItemWidth(Value: DWORD); + procedure SetItemHeight(Value: DWORD); + + procedure DefineProperties(Filer: TFiler); override; + procedure ReadData(Stream: Classes.TStream); + procedure WriteData(Stream: Classes.TStream); + + function AdditionalUnits: String; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String );override; + + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; override; + public + property DataStream: TMemoryStream read fDataStream write fDataStream; + function Pcode_Generate: Boolean; override; + function TypeName: String; override; + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function LoadBitmap: PBitmap; + published + property ItemWidth: DWORD read fItemWidth write SetItemWidth default 0; + property ItemHeight: DWORD read fItemHeight write SetItemHeight default 0; + property ImageType: TKOLGRushImageCollectionImageType read fImageType write SetImageType default None; + end; + +//************************************************************ + + TKOLGRushButton = class (TKOLButton) + protected + fStyles: TKOLGRushButtonStyles; + fOnRecalcRects: TOnRecalcRects; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + function CanNotChangeFontColor: Boolean; override; + function DefaultParentColor: Boolean; override; + function CanChangeColor: Boolean; override; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function TypeName: String; override; + function AdditionalUnits: String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushButtonStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushButtonStyles read fStyles write SetStyles; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + property Transparent; + + property ParentColor: Integer read fDummyProperty; + property VerticalAlign: Integer read fDummyProperty; + property TextAlign: Integer read fDummyProperty; + property Ctl3D: Integer read fDummyProperty; + property Flat: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property LikeSpeedButton: Integer read fDummyProperty; + property Windowed: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property Image: Integer read fDummyProperty; + property WordWrap: Integer read fDummyProperty; + end; + +//************************************************************ + + TKOLGRushPanel = class (TKOLPanel) + protected + fStyles: TKOLGRushPanelStyles; + fOnRecalcRects: TOnRecalcRects; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function ClientMargins: TRect; override; + function TypeName: String; override; + function AdditionalUnits: String; override; + function SetupParams(const AName, AParent: String): String; override; + function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushPanelStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushPanelStyles read fStyles write SetStyles; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + + property ParentColor: Integer read fDummyProperty; + property VerticalAlign: Integer read fDummyProperty; + property TextAlign: Integer read fDummyProperty; + property Ctl3D: Integer read fDummyProperty; + property EdgeStyle: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property ShowAccelChar: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property Brush: Integer read fDummyProperty; + end; + +//************************************************************ + + TKOLGRushCheckBox = class (TKOLCheckBox) + protected + fStyles: TKOLGRushCheckBoxStyles; + fOnRecalcRects: TOnRecalcRects; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function TypeName: String; override; + function AdditionalUnits: String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushCheckBoxStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushCheckBoxStyles read fStyles write SetStyles; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + + property Auto3State: Integer read fDummyProperty; + property Border: Integer read fDummyProperty; + property ParentColor: Integer read fDummyProperty; + property Ctl3D: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property HasBorder: Integer read fDummyProperty; + property Brush: Integer read fDummyProperty; + property Windowed: Integer read fDummyProperty; + property WordWrap: Integer read fDummyProperty; + end; + +//************************************************************ + + TKOLGRushRadioBox = class (TKOLRadioBox) + protected + fStyles: TKOLGRushRadioBoxStyles; + fOnRecalcRects: TOnRecalcRects; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function TypeName: String; override; + function AdditionalUnits: String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushRadioBoxStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushRadioBoxStyles read fStyles write SetStyles; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + + property Border: Integer read fDummyProperty; + property ParentColor: Integer read fDummyProperty; + property Ctl3D: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property HasBorder: Integer read fDummyProperty; + property Brush: Integer read fDummyProperty; + property Windowed: Integer read fDummyProperty; + property WordWrap: Integer read fDummyProperty; + end; + +//************************************************************ + + TKOLGRushSplitter = class (TKOLSplitter) + protected + fStyles: TKOLGRushSplitterStyles; + fCaption: String; + fLastAlign: TKOLAlign; + fOnRecalcRects: TOnRecalcRects; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + procedure SetCaption(const Value: String); override; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function TypeName: String; override; + function AdditionalUnits: String; override; + function SetupParams(const AName, AParent: String): String; override; + function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushSplitterStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + procedure Change; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushSplitterStyles read fStyles write SetStyles; + property Caption: String read fCaption write SetCaption; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + + property Brush: Integer read fDummyProperty; + property ParentColor: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property EdgeStyle: Integer read fDummyProperty; + property Ctl3D: Integer read fDummyProperty; + end; + +//************************************************************ + + TKOLGRushProgressBar = class (TKOLProgressBar) + protected + fStyles: TKOLGRushProgressBarStyles; + fCaption: String; + fOnRecalcRects: TOnRecalcRects; + fOnProgressChange: TOnProgressChange; + fImageCollection: TKOLGRushImageCollection; + + fDummyProperty: Integer; + procedure SetCaption(const Value: String); override; + procedure SetOnRecalcRects(const Value: TOnRecalcRects); + procedure SetOnProgressChange(const Value: TOnProgressChange); + procedure SetImageCollection(const Value: TKOLGRushImageCollection); + + function TypeName: String; override; + function AdditionalUnits: String; override; + function SetupParams(const AName, AParent: String): String; override; + function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; + procedure AssignEvents( SL: TStringList; const AName: String ); override; + function P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; override; + procedure SetStyles (Val: TKOLGRushProgressBarStyles); + public + constructor Create( AOwner: TComponent ); override; + destructor Destroy; override; + function Pcode_Generate: Boolean; override; + procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + published + property GRushStyles: TKOLGRushProgressBarStyles read fStyles write SetStyles; + property Caption: String read fCaption write SetCaption; + property OnRecalcRects: TOnRecalcRects read fOnRecalcRects write SetOnRecalcRects; + property OnProgressChange: TOnProgressChange read fOnProgressChange write SetOnProgressChange; + property imagecollection: TKOLGRushImageCollection read fImageCollection write SetImageCollection; + + property Brush: Integer read fDummyProperty; + property ParentColor: Integer read fDummyProperty; + property Color: Integer read fDummyProperty; + property EraseBackGround: Integer read fDummyProperty; + property ProgressColor: Integer read fDummyProperty; + property ProgressBKColor: Integer read fDummyProperty; + property Smooth: Integer read fDummyProperty; + property Vertical: Integer read fDummyProperty; + end; + +procedure Register; +procedure tinyLoadJPGGIFBMPStream(var TargetBitmap: KOL.PBitMap; Stream: Classes.TStream); +procedure TryResize(Control: KOL.PControl; W, H: Integer); + +implementation + +uses tinyPNG, tinyJPGGIFBMP; + +procedure Register; +begin + RegisterComponents( 'KOLGRushControls', [TKOLGRushButton, TKOLGRushPanel + , TKOLGRushCheckBox, TKOLGRushRadioBox, TKOLGRushSplitter, TKOLGRushProgressBar + , TKOLGRushImageCollection]); +end; + +procedure TryResize(Control: KOL.PControl; W, H: Integer); +begin + if W < Control.Width then begin + Control.Left := Control.Left + ((Control.Width-W) div 2); + Control.Width := W; + end; + if H < Control.Height then begin + Control.Top := Control.Top + ((Control.Height-H) div 2); + Control.Height := H; + end; +end; + +//************************************************************ + +constructor TKOLPaintState.Create; +begin + inherited Create; + fOwner := aOwner; +end; + +procedure TKOLPaintState.Assign( Source: TPersistent ); +var Val: TKOLPaintState; +begin + if Source is TKOLPaintState then begin + Val := Source as TKOLPaintState; + //fOwner := Val.fOwner; + fColorFrom := Val.fColorFrom; + fColorTo := Val.fColorTo; + fColorOuter := Val.fColorOuter; + fColorText := Val.fColorText; + fColorShadow := Val.fColorShadow; + fBorderColor := Val.fBorderColor; + fBorderRoundWidth := Val.fBorderRoundWidth; + fBorderRoundHeight := Val.fBorderRoundHeight; + fBorderWidth := Val.fBorderWidth; + fGradientStyle := Val.fGradientStyle; + fShadowOffset := Val.fShadowOffset; + fGlyphItemX := Val.fGlyphItemX; + fGlyphItemY := Val.fGlyphItemY; + + change; + end; +end; + +procedure TKOLPaintState.Change; +begin + if fOwner = nil then Exit; + if csLoading in fOwner.ComponentState then Exit; + (fOwner as TKOLControl).Change; +end; + +procedure TKOLPaintState.SetColorFrom; +begin fColorFrom := Value; Change; end; +procedure TKOLPaintState.SetColorTo; +begin fColorTo := Value; Change; end; +procedure TKOLPaintState.SetColorOuter; +begin fColorOuter := Value; Change; end; +procedure TKOLPaintState.SetColorText; +begin fColorText := Value; Change; end; +procedure TKOLPaintState.SetColorShadow; +begin fColorShadow := Value; Change; end; +procedure TKOLPaintState.SetBorderColor; +begin fBorderColor := Value; Change; end; +procedure TKOLPaintState.SetBorderRoundWidth; +begin fBorderRoundWidth := Value; Change; end; +procedure TKOLPaintState.SetBorderRoundHeight; +begin fBorderRoundHeight := Value; Change; end; +procedure TKOLPaintState.SetBorderWidth; +begin fBorderWidth := Value; Change; end; +procedure TKOLPaintState.SetGradientStyle; +begin fGradientStyle := Value; Change; end; +procedure TKOLPaintState.SetShadowOffset; +begin fShadowOffset := Value; Change; end; +procedure TKOLPaintState.SetGlyphItemX; +begin fGlyphItemX := Value; Change; end; +procedure TKOLPaintState.SetGlyphItemY; +begin fGlyphItemY := Value; Change; end; + +//************************************************************ + +constructor TKOLRect.Create; +begin + inherited Create; + fOwner := aOwner; + fLeft := aRect.Left; + fTop := aRect.Top; + fRight := aRect.Right; + fBottom := aRect.Bottom; +end; + +procedure TKOLRect.Assign( Source: TPersistent ); +var Val: TKOLRect; +begin + if Source is TKOLRect then begin + Val := Source as TKOLRect; + //fOwner := Val.fOwner; + fLeft := Val.fLeft; + fTop := Val.fTop; + fRight := Val.fRight; + fBottom := Val.fBottom; + Change; + end; +end; + +procedure TKOLRect.Change; +begin + if fOwner = nil then Exit; + if csLoading in fOwner.ComponentState then Exit; + (fOwner as TKOLControl).Change; +end; + +procedure TKOLRect.SetLeft; +begin fLeft := Value; Change; end; +procedure TKOLRect.SetTop; +begin fTop := Value; Change; end; +procedure TKOLRect.SetRight; +begin fRight := Value; Change; end; +procedure TKOLRect.SetBottom; +begin fBottom := Value; Change; end; + +//************************************************************ + +constructor TKOLGRushStyles.Create; +begin + inherited Create; + fOwner := aOwner; + fPSDef := TKOLPaintState.Create(aOwner); + fPSOver := TKOLPaintState.Create(aOwner); + fPSDown := TKOLPaintState.Create(aOwner); + fPSDis := TKOLPaintState.Create(aOwner); + fContentOffsets := TKOLRect.Create(aOwner, DefGRushData.fContentOffsets); + Move(DefGRushData.fPSDef, (@fPSDef.fColorFrom)^, sizeof (TGRushPaintState)); + Move(DefGRushData.fPSOver, (@fPSOver.fColorFrom)^, sizeof (TGRushPaintState)); + Move(DefGRushData.fPSDown, (@fPSDown.fColorFrom)^, sizeof (TGRushPaintState)); + Move(DefGRushData.fPSDis, (@fPSDis.fColorFrom)^, sizeof (TGRushPaintState)); + fGlyphWidth := DefGRushData.fGlyphWidth; + fGlyphHeight := DefGRushData.fGlyphHeight; + fCheckMetric := DefGRushData.fCheckMetric; + fColorCheck := DefGRushData.fColorCheck; + fGlyphVAlign := DefGRushData.fGlyphVAlign; + fGlyphHAlign := DefGRushData.fGlyphHAlign; + fTextVAlign := DefGRushData.fTextVAlign; + fTextHAlign := DefGRushData.fTextHAlign; + fDrawGlyph := DefGRushData.fDrawGlyph; + fDrawText := DefGRushData.fDrawText; + fDrawFocusRect := DefGRushData.fDrawFocusRect; + fDrawProgress := DefGRushData.fDrawProgress; + fDrawProgressRect := DefGRushData.fDrawProgressRect; + fGlyphAttached := DefGRushData.fGlyphAttached; + fCropTopFirst := DefGRushData.fCropTopFirst; + fAntiAliasing := DefGRushData.fAntiAliasing; + fProgressVertical := DefGRushData.fProgressVertical; + fUpdateSpeed := DefGRushData.fUpdateSpeed; + fSpacing := DefGRushData.fSpacing; + fSplitterDotsCount := DefGRushData.fSplitterDotsCount; +end; + +destructor TKOLGRushStyles.Destroy; +begin + fPSDef.Free; + fPSOver.Free; + fPSDown.Free; + fPSDis.Free; + fContentOffsets.Free; + inherited; +end; + +procedure TKOLGRushStyles.Assign (Source: TPersistent); +var Val: TKOLGRushStyles; +begin + if Source is TKOLGRushStyles then begin + Val := Source as TKOLGRushStyles; + //fOwner := Val.fOwner; + fPSDef.Assign( Val.fPSDef ); + fPSOver.Assign( Val.fPSOver ); + fPSDown.Assign( Val.fPSDown ); + fPSDis.Assign( Val.fPSDis ); + fContentOffsets.Assign( Val.fContentOffsets ); + fGlyphWidth := Val.fGlyphWidth; + fGlyphHeight := Val.fGlyphHeight; + fCheckMetric := Val.fCheckMetric; + fColorCheck := Val.fColorCheck; + fGlyphVAlign := Val.fGlyphVAlign; + fGlyphHAlign := Val.fGlyphHAlign; + fTextVAlign := Val.fTextVAlign; + fTextHAlign := Val.fTextHAlign; + fDrawGlyph := Val.fDrawGlyph; + fDrawText := Val.fDrawText; + fDrawFocusRect := Val.fDrawFocusRect; + fDrawProgress := Val.fDrawProgress; + fDrawProgressRect := Val.fDrawProgressRect; + fGlyphAttached := Val.fGlyphAttached; + fCropTopFirst := Val.fCropTopFirst; + fAntiAliasing := Val.fAntiAliasing; + fProgressVertical := Val.fProgressVertical; + fUpdateSpeed := Val.fUpdateSpeed; + fSpacing := Val.fSpacing; + fSplitterDotsCount := Val.fSplitterDotsCount; + Change; + end; +end; + +procedure TKOLGRushStyles.Change; +begin + if fOwner = nil then Exit; + if csLoading in fOwner.ComponentState then Exit; + (fOwner as TKOLControl).Change; +end; + +procedure TKOLGRushStyles.SetGlyphWidth; +begin fGlyphWidth := Value; Change; end; +procedure TKOLGRushStyles.SetGlyphHeight; +begin fGlyphHeight := Value; Change; end; +procedure TKOLGRushStyles.SetCheckMetric; +begin fCheckMetric := Value; Change; end; +procedure TKOLGRushStyles.SetColorCheck; +begin fColorCheck := Value; Change; end; +procedure TKOLGRushStyles.SetGlyphVAlign; +begin fGlyphVAlign := Value; Change; end; +procedure TKOLGRushStyles.SetGlyphHAlign; +begin fGlyphHAlign := Value; Change; end; +procedure TKOLGRushStyles.SetTextVAlign; +begin fTextVAlign := Value; Change; end; +procedure TKOLGRushStyles.SetTextHAlign; +begin fTextHAlign := Value; Change; end; +procedure TKOLGRushStyles.SetDrawGlyph; +begin fDrawGlyph := Value; Change; end; +procedure TKOLGRushStyles.SetDrawText; +begin fDrawText := Value; Change; end; +procedure TKOLGRushStyles.SetDrawFocusRect; +begin fDrawFocusRect := Value; Change; end; +procedure TKOLGRushStyles.SetDrawProgress; +begin fDrawProgress := Value; Change; end; +procedure TKOLGRushStyles.SetDrawProgressRect; +begin fDrawProgressRect := Value; Change; end; +procedure TKOLGRushStyles.SetGlyphAttached; +begin fGlyphAttached := Value; Change; end; +procedure TKOLGRushStyles.SetCropTopFirst; +begin fCropTopFirst := Value; Change; end; +procedure TKOLGRushStyles.SetAntiAliasing; +begin fAntiAliasing := Value; Change; end; +procedure TKOLGRushStyles.SetProgressVertical; +begin fProgressVertical := Value; SetUpProgressVertical(Value); Change; end; +procedure TKOLGRushStyles.SetUpdateSpeed; +begin fUpdateSpeed := Value; Change; end; +procedure TKOLGRushStyles.SetSpacing; +begin fSpacing := Value; Change; end; +procedure TKOLGRushStyles.SetSplitterDotsCount; +begin fSplitterDotsCount := Value; Change; end; + +procedure TKOLGRushStyles.SetUpProgressVertical; +begin + if Value then begin + fPSDef.fBorderRoundWidth := 25; + fPSDef.fBorderRoundHeight := 4; + fPSOver.fBorderRoundWidth := 25; + fPSOver.fBorderRoundHeight := 4; + fPSDown.fBorderRoundWidth := 25; + fPSDown.fBorderRoundHeight := 4; + fPSDis.fBorderRoundWidth := 25; + fPSDis.fBorderRoundHeight := 4; + fPSDef.fGradientStyle := gsDoubleHorz; + fPSOver.fGradientStyle := gsDoubleHorz; + fPSDown.fGradientStyle := gsDoubleHorz; + fPSDis.fGradientStyle := gsDoubleHorz; + end else begin + fPSDef.fBorderRoundWidth := 4; + fPSDef.fBorderRoundHeight := 25; + fPSOver.fBorderRoundWidth := 4; + fPSOver.fBorderRoundHeight := 25; + fPSDown.fBorderRoundWidth := 4; + fPSDown.fBorderRoundHeight := 25; + fPSDis.fBorderRoundWidth := 4; + fPSDis.fBorderRoundHeight := 25; + fPSDef.fGradientStyle := gsDoubleVert; + fPSOver.fGradientStyle := gsDoubleVert; + fPSDown.fGradientStyle := gsDoubleVert; + fPSDis.fGradientStyle := gsDoubleVert; + end; +end; +procedure TKOLGRushStyles.SetUpSplitterAlign; +begin + if (fPSOver = nil) or (fPSDown = nil) or (fPSDis = nil) then exit; + if Value then begin + fPSOver.fGradientStyle := gsHorizontal; + fPSDown.fGradientStyle := gsHorizontal; + fPSDis.fGradientStyle := gsHorizontal; + end else begin + fPSOver.fGradientStyle := gsVertical; + fPSDown.fGradientStyle := gsVertical; + fPSDis.fGradientStyle := gsVertical; + end; +end; + +//************************************************************ + +constructor TKOLGRushPanelStyles.Create; +begin + inherited; + fTextVAlign := KOL.vaTop; + fPSDef.fBorderRoundWidth := 6; + fPSDef.fBorderRoundHeight := 6; + fPSDis.fBorderRoundWidth := 6; + fPSDis.fBorderRoundHeight := 6; +end; + +//************************************************************ + +constructor TKOLGRushCheckBoxStyles.Create; +begin + inherited; + fTextHAlign := haLeft; + fContentOffsets.Free; + fContentOffsets := TKOLRect.Create(aOwner, CheckContentRect); + + fPSDef.fBorderRoundWidth := 0; + fPSDef.fBorderRoundHeight := 0; + fPSOver.fBorderRoundWidth := 0; + fPSOver.fBorderRoundHeight := 0; + fPSDown.fBorderRoundWidth := 0; + fPSDown.fBorderRoundHeight := 0; + fPSDis.fBorderRoundWidth := 0; + fPSDis.fBorderRoundHeight := 0; + + fPSDef.fBorderColor := clGray; + fPSOver.fBorderColor := $404040; + fPSDown.fBorderColor := clGray; + fPSDis.fBorderColor := clGray; + + fPSDef.fGradientStyle := gsFromTopLeft; + fPSOver.fGradientStyle := gsFromTopLeft; + fPSDown.fGradientStyle := gsFromTopLeft; + fPSDis.fGradientStyle := gsFromTopLeft; +end; + +//************************************************************ + +constructor TKOLGRushRadioBoxStyles.Create; +begin + inherited; + fTextHAlign := haLeft; + fContentOffsets.Free; + fContentOffsets := TKOLRect.Create(aOwner, CheckContentRect); + + fPSDef.fBorderRoundWidth := 50; + fPSDef.fBorderRoundHeight := 50; + fPSOver.fBorderRoundWidth := 50; + fPSOver.fBorderRoundHeight := 50; + fPSDown.fBorderRoundWidth := 50; + fPSDown.fBorderRoundHeight := 50; + fPSDis.fBorderRoundWidth := 50; + fPSDis.fBorderRoundHeight := 50; + + fPSDef.fBorderColor := clGray; + fPSOver.fBorderColor := $404040; + fPSDown.fBorderColor := clGray; + fPSDis.fBorderColor := clGray; + + fPSDef.fGradientStyle := gsFromTopLeft; + fPSOver.fGradientStyle := gsFromTopLeft; + fPSDown.fGradientStyle := gsFromTopLeft; + fPSDis.fGradientStyle := gsFromTopLeft; +end; + +//************************************************************ + +constructor TKOLGRushSplitterStyles.Create; +begin + inherited; + fPSOver.fColorTo := $D0AD95; + fPSDown.fColorTo := $C39475; + fUpdateSpeed := usVeryFast; + fSplitterDotsCount := 16; + + SetUpSplitterAlign((fOwner as TKOLCustomControl).Align in [mirror.caLeft, mirror.caRight]); + fPSDef.fGradientStyle := gsSolid; + + fPSDef.fColorFrom := clBtnFace; + fPSOver.fColorFrom := clWhite; + fPSDown.fColorFrom := clWhite; + fPSDis.fColorFrom := clWhite; + + fPSDef.fBorderWidth := 0; + fPSOver.fBorderWidth := 0; + fPSDown.fBorderWidth := 0; + fPSDis.fBorderWidth := 0; + fPSDef.fBorderRoundWidth := 0; + fPSDef.fBorderRoundHeight := 0; + fPSOver.fBorderRoundWidth := 0; + fPSOver.fBorderRoundHeight := 0; + fPSDown.fBorderRoundWidth := 0; + fPSDown.fBorderRoundHeight := 0; + fPSDis.fBorderRoundWidth := 0; + fPSDis.fBorderRoundHeight := 0; +end; + +//************************************************************ + +constructor TKOLGRushProgressBarStyles.Create; +begin + inherited; + fContentOffsets.Free; + fContentOffsets := TKOLRect.Create(aOwner, ProgressBarContentRect); + fDrawProgress := TRUE; + fDrawProgressRect := TRUE; + fPSDef.fColorTo := $B6977E; + fPSDef.fColorFrom := $E0D2C9; + fPSDef.fShadowOffset := 1; + fPSOver.fShadowOffset := 1; + fPSDown.fShadowOffset := 1; + fPSDis.fShadowOffset := 1; + + fPSDef.fBorderWidth := 1; + fPSOver.fBorderWidth := 1; + fPSDown.fBorderWidth := 1; + fPSDis.fBorderWidth := 1; + + SetUpProgressVertical(FALSE); +end; + +//************************************************************ + +procedure SetUpCommon (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; const AName, Prefix: String; DefStyles: TKOLGrushStyles; + ImageCollection: TKOLGRushImageCollection); +const TVAligns: array [KOL.TVerticalAlign] of String = ('KOL.vaTop', 'KOL.vaCenter', 'vaBottom'); + THAligns: array [TGRushHAlign] of String = ('haLeft', 'haCenter', 'haRight'); + Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); +begin + if (Styles.fContentOffsets.fLeft <> DefStyles.fContentOffsets.fLeft) + or (Styles.fContentOffsets.fTop <> DefStyles.fContentOffsets.fTop) + or (Styles.fContentOffsets.fRight <> DefStyles.fContentOffsets.fRight) + or (Styles.fContentOffsets.fBottom <> DefStyles.fContentOffsets.fBottom) then + begin + SL.Add( Prefix + AName + '.All_ContentOffsets := MakeRect( '+Int2str(Styles.fContentOffsets.fLeft)+', ' + +Int2str(Styles.fContentOffsets.fTop)+', '+Int2str(Styles.fContentOffsets.fRight)+', ' + +Int2str(Styles.fContentOffsets.fBottom)+');') + end; + {if Styles.fGlyphWidth <> DefStyles.fGlyphWidth then + SL.Add( Prefix + AName + '.All_GlyphWidth := '+int2str(Styles.fGlyphWidth)+';'); + if Styles.fGlyphHeight <> DefStyles.fGlyphHeight then + SL.Add( Prefix + AName + '.All_GlyphHeight := '+int2str(Styles.fGlyphHeight)+';');} + if Assigned(ImageCollection) and (ImageCollection.fImageType <> None) then begin + SL.Add( Prefix + AName + '.All_GlyphBitmap := Result.' + ImageCollection.Name + ';'); + if Styles.fGlyphWidth <> 0 then + SL.Add( Prefix + AName + '.All_GlyphWidth := ' + inttostr(Styles.fGlyphWidth) + ';') + else if ImageCollection.fItemWidth <> 0 then + SL.Add( Prefix + AName + '.All_GlyphWidth := ' + inttostr(ImageCollection.fItemWidth) + ';'); + if Styles.fGlyphHeight <> 0 then + SL.Add( Prefix + AName + '.All_GlyphHeight := ' + inttostr(Styles.fGlyphHeight) + ';') + else if ImageCollection.fItemHeight <> 0 then + SL.Add( Prefix + AName + '.All_GlyphHeight := ' + inttostr(ImageCollection.fItemHeight) + ';'); + end; + if Styles.fGlyphVAlign <> DefStyles.fGlyphVAlign then + SL.Add( Prefix + AName + '.All_GlyphVAlign := '+TVAligns[Styles.fGlyphVAlign]+';'); + if Styles.fGlyphHAlign <> DefStyles.fGlyphHAlign then + SL.Add( Prefix + AName + '.All_GlyphHAlign := '+THAligns[Styles.fGlyphHAlign]+';'); + if Styles.fTextVAlign <> DefStyles.fTextVAlign then + SL.Add( Prefix + AName + '.All_TextVAlign := '+TVAligns[Styles.fTextVAlign]+';'); + if Styles.fTextHAlign <> DefStyles.fTextHAlign then + SL.Add( Prefix + AName + '.All_TextHAlign := '+THAligns[Styles.fTextHAlign]+';'); + if Styles.fDrawGlyph <> DefStyles.fDrawGlyph then + SL.Add( Prefix + AName + '.All_DrawGlyph := '+Booleans[Styles.fDrawGlyph]+';'); + if Styles.fDrawText <> DefStyles.fDrawText then + SL.Add( Prefix + AName + '.All_DrawText := '+Booleans[Styles.fDrawText]+';'); + if Styles.fGlyphAttached <> DefStyles.fGlyphAttached then + SL.Add( Prefix + AName + '.All_GlyphAttached := '+Booleans[Styles.fGlyphAttached]+';'); + if Styles.fCropTopFirst <> DefStyles.fCropTopFirst then + SL.Add( Prefix + AName + '.All_CropTopFirst := '+Booleans[Styles.fCropTopFirst]+';'); + if Styles.fAntiAliasing <> DefStyles.fAntiAliasing then + SL.Add( Prefix + AName + '.All_AntiAliasing := '+Booleans[Styles.fAntiAliasing]+';'); + if Styles.fSpacing <> DefStyles.fSpacing then + SL.Add( Prefix + AName + '.All_Spacing := '+int2str(Styles.fSpacing)+';'); +end; + +procedure P_SetUpCommon (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; DefStyles: TKOLGrushStyles); +begin + if (Styles.fContentOffsets.fLeft <> DefStyles.fContentOffsets.fLeft) + or (Styles.fContentOffsets.fTop <> DefStyles.fContentOffsets.fTop) + or (Styles.fContentOffsets.fRight <> DefStyles.fContentOffsets.fRight) + or (Styles.fContentOffsets.fBottom <> DefStyles.fContentOffsets.fBottom) then + begin + SL.Add('L('+Int2Str(Styles.fContentOffsets.fBottom) + +') L('+Int2Str(Styles.fContentOffsets.fRight) + +') L('+Int2Str(Styles.fContentOffsets.fTop) + +') L('+Int2Str(Styles.fContentOffsets.fLeft) + +') LoadStack C5 GR0O_.SetAll_ContentOffsets<2> L(4) DelN'); + end; + + if Styles.fGlyphWidth <> DefStyles.fGlyphWidth then + SL.Add( ' L(' + int2str(Styles.fGlyphWidth) + ') C1 GR0O_.SetAll_GlyphWidth<2>' ); + if Styles.fGlyphHeight <> DefStyles.fGlyphHeight then + SL.Add( ' L(' + int2str(Styles.fGlyphHeight) + ') C1 GR0O_.SetAll_GlyphHeight<2>' ); + if Styles.fGlyphVAlign <> DefStyles.fGlyphVAlign then + SL.Add( ' L(' + int2str( Byte ( Styles.fGlyphVAlign ) ) + ') C1 GR0O_.SetAll_GlyphVAlign<2>' ); + if Styles.fGlyphHAlign <> DefStyles.fGlyphHAlign then + SL.Add( ' L(' + int2str( Byte ( Styles.fGlyphHAlign ) ) + ') C1 GR0O_.SetAll_GlyphHAlign<2>' ); + if Styles.fTextVAlign <> DefStyles.fTextVAlign then + SL.Add( ' L(' + int2str( Byte ( Styles.fTextVAlign ) ) + ') C1 GR0O_.SetAll_TextVAlign<2>' ); + if Styles.fTextHAlign <> DefStyles.fTextHAlign then + SL.Add( ' L(' + int2str( Byte ( Styles.fTextHAlign ) ) + ') C1 GR0O_.SetAll_TextHAlign<2>' ); + if Styles.fDrawGlyph <> DefStyles.fDrawGlyph then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawGlyph<2>' ); + if Styles.fDrawText <> DefStyles.fDrawText then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawText<2>' ); + if Styles.fGlyphAttached <> DefStyles.fGlyphAttached then + SL.Add( ' L(1) C1 GR0O_.SetAll_GlyphAttached<2>' ); + if Styles.fCropTopFirst <> DefStyles.fCropTopFirst then + SL.Add( ' L(0) C1 GR0O_.SetAll_CropTopFirst<2>' ); + if Styles.fAntialiasing <> DefStyles.fAntialiasing then + SL.Add( ' L(0) C1 GR0O_.SetAll_Antialiasing<2>' ); + if Styles.fSpacing <> DefStyles.fSpacing then + SL.Add( ' L(' + int2str( Styles.fSpacing ) + ') C1 GR0O_.SetAll_Spacing<2>' ); +end; + +//************************************************************ + +procedure SetUpState2States (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; const AName, Prefix: String; DefStyles: TKOLGrushStyles); +const GradientStyles: array [TGRushGradientStyle] of String = ('gsSolid', 'gsVertical' + , 'gsHorizontal', 'gsDoubleVert', 'gsDoubleHorz', 'gsFromTopLeft', 'gsFromTopRight'); +begin + if (Styles.fPSDef.fColorFrom = Styles.fPSDis.fColorFrom) + and (Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom) then + SL.Add( Prefix + AName + '.All_ColorFrom := '+Int2str(Styles.fPSDef.fColorFrom)+';') + else begin + if Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom then + SL.Add( Prefix + AName + '.Def_ColorFrom := '+Int2str(Styles.fPSDef.fColorFrom)+';'); + if Styles.fPSDis.fColorFrom <> DefStyles.fPSDis.fColorFrom then + SL.Add( Prefix + AName + '.Dis_ColorFrom := '+Int2str(Styles.fPSDis.fColorFrom)+';'); + end; + + if (Styles.fPSDef.fColorTo = Styles.fPSDis.fColorTo) + and (Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo) then + SL.Add( Prefix + AName + '.All_ColorTo := '+Int2str(Styles.fPSDef.fColorTo)+';') + else begin + if Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo then + SL.Add( Prefix + AName + '.Def_ColorTo := '+Int2str(Styles.fPSDef.fColorTo)+';'); + if Styles.fPSDis.fColorTo <> DefStyles.fPSDis.fColorTo then + SL.Add( Prefix + AName + '.Dis_ColorTo := '+Int2str(Styles.fPSDis.fColorTo)+';'); + end; + + if (Styles.fPSDef.fColorOuter = Styles.fPSDis.fColorOuter) + and (Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter) then + SL.Add( Prefix + AName + '.All_ColorOuter := '+Int2str(Styles.fPSDef.fColorOuter)+';') + else begin + if Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter then + SL.Add( Prefix + AName + '.Def_ColorOuter := '+Int2str(Styles.fPSDef.fColorOuter)+';'); + if Styles.fPSDis.fColorOuter <> DefStyles.fPSDis.fColorOuter then + SL.Add( Prefix + AName + '.Dis_ColorOuter := '+Int2str(Styles.fPSDis.fColorOuter)+';'); + end; + + if (Styles.fPSDef.fColorText = Styles.fPSDis.fColorText) + and (Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText) then + SL.Add( Prefix + AName + '.All_ColorText := '+Int2str(Styles.fPSDef.fColorText)+';') + else begin + if Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText then + SL.Add( Prefix + AName + '.Def_ColorText := '+Int2str(Styles.fPSDef.fColorText)+';'); + if Styles.fPSDis.fColorText <> DefStyles.fPSDis.fColorText then + SL.Add( Prefix + AName + '.Dis_ColorText := '+Int2str(Styles.fPSDis.fColorText)+';'); + end; + + if (Styles.fPSDef.fColorShadow = Styles.fPSDis.fColorShadow) + and (Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow) then + SL.Add( Prefix + AName + '.All_ColorShadow := '+Int2str(Styles.fPSDef.fColorShadow)+';') + else begin + if Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow then + SL.Add( Prefix + AName + '.Def_ColorShadow := '+Int2str(Styles.fPSDef.fColorShadow)+';'); + if Styles.fPSDis.fColorShadow <> DefStyles.fPSDis.fColorShadow then + SL.Add( Prefix + AName + '.Dis_ColorShadow := '+Int2str(Styles.fPSDis.fColorShadow)+';'); + end; + + if (Styles.fPSDef.fBorderColor = Styles.fPSDis.fBorderColor) + and (Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor) then + SL.Add( Prefix + AName + '.All_BorderColor := '+Int2str(Styles.fPSDef.fBorderColor)+';') + else begin + if Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor then + SL.Add( Prefix + AName + '.Def_BorderColor := '+Int2str(Styles.fPSDef.fBorderColor)+';'); + if Styles.fPSDis.fBorderColor <> DefStyles.fPSDis.fBorderColor then + SL.Add( Prefix + AName + '.Dis_BorderColor := '+Int2str(Styles.fPSDis.fBorderColor)+';'); + end; + + if (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDis.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth) then + SL.Add( Prefix + AName + '.All_BorderRoundWidth := '+Int2Str(Styles.fPSDef.fBorderRoundWidth)+';') + else begin + if Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Def_BorderRoundWidth := '+Int2Str(Styles.fPSDef.fBorderRoundWidth)+';'); + if Styles.fPSDis.fBorderRoundWidth <> DefStyles.fPSDis.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Dis_BorderRoundWidth := '+Int2Str(Styles.fPSDis.fBorderRoundWidth)+';'); + end; + + if (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDis.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight) then + SL.Add( Prefix + AName + '.All_BorderRoundHeight := '+Int2Str(Styles.fPSDef.fBorderRoundHeight)+';') + else begin + if Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Def_BorderRoundHeight := '+Int2Str(Styles.fPSDef.fBorderRoundHeight)+';'); + if Styles.fPSDis.fBorderRoundHeight <> DefStyles.fPSDis.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Dis_BorderRoundHeight := '+Int2Str(Styles.fPSDis.fBorderRoundHeight)+';'); + end; + + if (Styles.fPSDef.fBorderWidth = Styles.fPSDis.fBorderWidth) + and (Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth) then + SL.Add( Prefix + AName + '.All_BorderWidth := '+Int2Str(Styles.fPSDef.fBorderWidth)+';') + else begin + if Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth then + SL.Add( Prefix + AName + '.Def_BorderWidth := '+Int2Str(Styles.fPSDef.fBorderWidth)+';'); + if Styles.fPSDis.fBorderWidth <> DefStyles.fPSDis.fBorderWidth then + SL.Add( Prefix + AName + '.Dis_BorderWidth := '+Int2Str(Styles.fPSDis.fBorderWidth)+';'); + end; + + if (Styles.fPSDef.fGradientStyle = Styles.fPSDis.fGradientStyle) + and (Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle) then + SL.Add( Prefix + AName + '.All_GradientStyle := '+GradientStyles[Styles.fPSDef.fGradientStyle]+';') + else begin + if Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle then + SL.Add( Prefix + AName + '.Def_GradientStyle := '+GradientStyles[Styles.fPSDef.fGradientStyle]+';'); + if Styles.fPSDis.fGradientStyle <> DefStyles.fPSDis.fGradientStyle then + SL.Add( Prefix + AName + '.Dis_GradientStyle := '+GradientStyles[Styles.fPSDis.fGradientStyle]+';'); + end; + + if (Styles.fPSDef.fShadowOffset = Styles.fPSDis.fShadowOffset) + and (Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset) then + SL.Add( Prefix + AName + '.All_ShadowOffset := '+Int2Str(Styles.fPSDef.fShadowOffset)+';') + else begin + if Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset then + SL.Add( Prefix + AName + '.Def_ShadowOffset := '+Int2Str(Styles.fPSDef.fShadowOffset)+';'); + if Styles.fPSDis.fShadowOffset <> DefStyles.fPSDis.fShadowOffset then + SL.Add( Prefix + AName + '.Dis_ShadowOffset := '+Int2Str(Styles.fPSDis.fShadowOffset)+';'); + end; + + if (Styles.fPSDef.fGlyphItemX = Styles.fPSDis.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX) then + SL.Add( Prefix + AName + '.All_GlyphItemX := '+Int2Str(Styles.fPSDef.fGlyphItemX)+';') + else begin + if Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX then + SL.Add( Prefix + AName + '.Def_GlyphItemX := '+Int2Str(Styles.fPSDef.fGlyphItemX)+';'); + if Styles.fPSDis.fGlyphItemX <> DefStyles.fPSDis.fGlyphItemX then + SL.Add( Prefix + AName + '.Dis_GlyphItemX := '+Int2Str(Styles.fPSDis.fGlyphItemX)+';'); + end; + + if (Styles.fPSDef.fGlyphItemY = Styles.fPSDis.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY) then + SL.Add( Prefix + AName + '.All_GlyphItemY := '+Int2Str(Styles.fPSDef.fGlyphItemY)+';') + else begin + if Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY then + SL.Add( Prefix + AName + '.Def_GlyphItemY := '+Int2Str(Styles.fPSDef.fGlyphItemY)+';'); + if Styles.fPSDis.fGlyphItemY <> DefStyles.fPSDis.fGlyphItemY then + SL.Add( Prefix + AName + '.Dis_GlyphItemY := '+Int2Str(Styles.fPSDis.fGlyphItemY)+';'); + end; +end; + +procedure P_SetUpState2States (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; DefStyles: TKOLGrushStyles); +begin + if (Styles.fPSDef.fColorFrom = Styles.fPSOver.fColorFrom) + and (Styles.fPSDef.fColorFrom = Styles.fPSDis.fColorFrom) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorFrom ) + ') C1 GR0O_.SetAll_ColorFrom<2>' ) + else begin + if Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorFrom ) + ') C1 GR0O_.SetDef_ColorFrom<2>' ); + if Styles.fPSDown.fColorFrom <> DefStyles.fPSDown.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorFrom ) + ') C1 GR0O_.SetDown_ColorFrom<2>' ); + end; + + if (Styles.fPSDef.fColorTo = Styles.fPSOver.fColorTo) + and (Styles.fPSDef.fColorTo = Styles.fPSDis.fColorTo)then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorTo ) + ') C1 GR0O_.SetAll_ColorTo<2>' ) + else begin + if Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorTo ) + ') C1 GR0O_.SetDef_ColorTo<2>' ); + if Styles.fPSDown.fColorTo <> DefStyles.fPSDown.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorTo ) + ') C1 GR0O_.SetDown_ColorTo<2>' ); + end; + + if (Styles.fPSDef.fColorOuter = Styles.fPSOver.fColorOuter) + and (Styles.fPSDef.fColorOuter = Styles.fPSDis.fColorOuter) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorOuter ) + ') C1 GR0O_.SetAll_ColorOuter<2>' ) + else begin + if Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorOuter ) + ') C1 GR0O_.SetDef_ColorOuter<2>' ); + if Styles.fPSDown.fColorOuter <> DefStyles.fPSDown.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorOuter ) + ') C1 GR0O_.SetDown_ColorOuter<2>' ); + end; + + if (Styles.fPSDef.fColorText = Styles.fPSOver.fColorText) + and (Styles.fPSDef.fColorText = Styles.fPSDis.fColorText) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorText ) + ') C1 GR0O_.SetAll_ColorText<2>' ) + else begin + if Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorText ) + ') C1 GR0O_.SetDef_ColorText<2>' ); + if Styles.fPSDown.fColorText <> DefStyles.fPSDown.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorText ) + ') C1 GR0O_.SetDown_ColorText<2>' ); + end; + + if (Styles.fPSDef.fColorShadow = Styles.fPSOver.fColorShadow) + and (Styles.fPSDef.fColorShadow = Styles.fPSDis.fColorShadow) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorShadow ) + ') C1 GR0O_.SetAll_ColorShadow<2>' ) + else begin + if Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorShadow ) + ') C1 GR0O_.SetDef_ColorShadow<2>' ); + if Styles.fPSDown.fColorShadow <> DefStyles.fPSDown.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorShadow ) + ') C1 GR0O_.SetDown_ColorShadow<2>' ); + end; + + if (Styles.fPSDef.fBorderColor = Styles.fPSOver.fBorderColor) + and (Styles.fPSDef.fBorderColor = Styles.fPSDis.fBorderColor) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderColor ) + ') C1 GR0O_.SetAll_BorderColor<2>' ) + else begin + if Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderColor ) + ') C1 GR0O_.SetDef_BorderColor<2>' ); + if Styles.fPSDown.fBorderColor <> DefStyles.fPSDown.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderColor ) + ') C1 GR0O_.SetDown_BorderColor<2>' ); + end; + + if (Styles.fPSDef.fBorderRoundWidth = Styles.fPSOver.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDis.fBorderRoundWidth) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundWidth ) + ') C1 GR0O_.SetAll_BorderRoundWidth<2>' ) + else begin + if Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundWidth ) + ') C1 GR0O_.SetDef_BorderRoundWidth<2>' ); + if Styles.fPSDown.fBorderRoundWidth <> DefStyles.fPSDown.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderRoundWidth ) + ') C1 GR0O_.SetDown_BorderRoundWidth<2>' ); + end; + + if (Styles.fPSDef.fBorderRoundHeight = Styles.fPSOver.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDis.fBorderRoundHeight) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundHeight ) + ') C1 GR0O_.SetAll_BorderRoundHeight<2>' ) + else begin + if Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundHeight ) + ') C1 GR0O_.SetDef_BorderRoundHeight<2>' ); + if Styles.fPSDown.fBorderRoundHeight <> DefStyles.fPSDown.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderRoundHeight ) + ') C1 GR0O_.SetDown_BorderRoundHeight<2>' ); + end; + + if (Styles.fPSDef.fBorderWidth = Styles.fPSOver.fBorderWidth) + and (Styles.fPSDef.fBorderWidth = Styles.fPSDis.fBorderWidth)then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderWidth ) + ') C1 GR0O_.SetAll_BorderWidth<2>' ) + else begin + if Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderWidth ) + ') C1 GR0O_.SetDef_BorderWidth<2>' ); + if Styles.fPSDown.fBorderWidth <> DefStyles.fPSDown.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderWidth ) + ') C1 GR0O_.SetDown_BorderWidth<2>' ); + end; + + if (Styles.fPSDef.fGradientStyle = Styles.fPSOver.fGradientStyle) + and (Styles.fPSDef.fGradientStyle = Styles.fPSDis.fGradientStyle) then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDef.fGradientStyle ) ) + ') C1 GR0O_.SetAll_GradientStyle<2>' ) + else begin + if Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDef.fGradientStyle ) ) + ') C1 GR0O_.SetDef_GradientStyle<2>' ); + if Styles.fPSDown.fGradientStyle <> DefStyles.fPSDown.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDown.fGradientStyle ) ) + ') C1 GR0O_.SetDown_GradientStyle<2>' ); + end; + + if (Styles.fPSDef.fShadowOffset = Styles.fPSOver.fShadowOffset) + and (Styles.fPSDef.fShadowOffset = Styles.fPSDis.fShadowOffset) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fShadowOffset ) + ') C1 GR0O_.SetAll_ShadowOffset<2>' ) + else begin + if Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fShadowOffset ) + ') C1 GR0O_.SetDef_ShadowOffset<2>' ); + if Styles.fPSDown.fShadowOffset <> DefStyles.fPSDown.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fShadowOffset ) + ') C1 GR0O_.SetDown_ShadowOffset<2>' ); + end; + + if (Styles.fPSDef.fGlyphItemX = Styles.fPSOver.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX = Styles.fPSDis.fGlyphItemX) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemX ) + ') C1 GR0O_.SetAll_GlyphItemX<2>' ) + else begin + if Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemX ) + ') C1 GR0O_.SetDef_GlyphItemX<2>' ); + if Styles.fPSDown.fGlyphItemX <> DefStyles.fPSDown.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fGlyphItemX ) + ') C1 GR0O_.SetDown_GlyphItemX<2>' ); + end; + + if (Styles.fPSDef.fGlyphItemY = Styles.fPSOver.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY = Styles.fPSDis.fGlyphItemY) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemY ) + ') C1 GR0O_.SetAll_GlyphItemY<2>' ) + else begin + if Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemY ) + ') C1 GR0O_.SetDef_GlyphItemY<2>' ); + if Styles.fPSDown.fGlyphItemY <> DefStyles.fPSDown.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fGlyphItemY ) + ') C1 GR0O_.SetDown_GlyphItemY<2>' ); + end; +end; + +//************************************************************ + +procedure SetUpState4States (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; const AName, Prefix: String; DefStyles: TKOLGrushStyles); +const GradientStyles: array [TGRushGradientStyle] of String = ('gsSolid', 'gsVertical' + , 'gsHorizontal', 'gsDoubleVert', 'gsDoubleHorz', 'gsFromTopLeft', 'gsFromTopRight'); +begin + if (Styles.fPSDef.fColorFrom = Styles.fPSOver.fColorFrom) + and (Styles.fPSDef.fColorFrom = Styles.fPSDown.fColorFrom) + and (Styles.fPSDef.fColorFrom = Styles.fPSDis.fColorFrom) + and (Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom) then + SL.Add( Prefix + AName + '.All_ColorFrom := '+Int2str(Styles.fPSDef.fColorFrom)+';') + else begin + if Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom then + SL.Add( Prefix + AName + '.Def_ColorFrom := '+Int2str(Styles.fPSDef.fColorFrom)+';'); + if Styles.fPSOver.fColorFrom <> DefStyles.fPSOver.fColorFrom then + SL.Add( Prefix + AName + '.Over_ColorFrom := '+Int2str(Styles.fPSOver.fColorFrom)+';'); + if Styles.fPSDown.fColorFrom <> DefStyles.fPSDown.fColorFrom then + SL.Add( Prefix + AName + '.Down_ColorFrom := '+Int2str(Styles.fPSDown.fColorFrom)+';'); + if Styles.fPSDis.fColorFrom <> DefStyles.fPSDis.fColorFrom then + SL.Add( Prefix + AName + '.Dis_ColorFrom := '+Int2str(Styles.fPSDis.fColorFrom)+';'); + end; + + if (Styles.fPSDef.fColorTo = Styles.fPSOver.fColorTo) + and (Styles.fPSDef.fColorTo = Styles.fPSDown.fColorTo) + and (Styles.fPSDef.fColorTo = Styles.fPSDis.fColorTo) + and (Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo) then + SL.Add( Prefix + AName + '.All_ColorTo := '+Int2str(Styles.fPSDef.fColorTo)+';') + else begin + if Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo then + SL.Add( Prefix + AName + '.Def_ColorTo := '+Int2str(Styles.fPSDef.fColorTo)+';'); + if Styles.fPSOver.fColorTo <> DefStyles.fPSOver.fColorTo then + SL.Add( Prefix + AName + '.Over_ColorTo := '+Int2str(Styles.fPSOver.fColorTo)+';'); + if Styles.fPSDown.fColorTo <> DefStyles.fPSDown.fColorTo then + SL.Add( Prefix + AName + '.Down_ColorTo := '+Int2str(Styles.fPSDown.fColorTo)+';'); + if Styles.fPSDis.fColorTo <> DefStyles.fPSDis.fColorTo then + SL.Add( Prefix + AName + '.Dis_ColorTo := '+Int2str(Styles.fPSDis.fColorTo)+';'); + end; + + if (Styles.fPSDef.fColorOuter = Styles.fPSOver.fColorOuter) + and (Styles.fPSDef.fColorOuter = Styles.fPSDown.fColorOuter) + and (Styles.fPSDef.fColorOuter = Styles.fPSDis.fColorOuter) + and (Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter) then + SL.Add( Prefix + AName + '.All_ColorOuter := '+Int2str(Styles.fPSDef.fColorOuter)+';') + else begin + if Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter then + SL.Add( Prefix + AName + '.Def_ColorOuter := '+Int2str(Styles.fPSDef.fColorOuter)+';'); + if Styles.fPSOver.fColorOuter <> DefStyles.fPSOver.fColorOuter then + SL.Add( Prefix + AName + '.Over_ColorOuter := '+Int2str(Styles.fPSOver.fColorOuter)+';'); + if Styles.fPSDown.fColorOuter <> DefStyles.fPSDown.fColorOuter then + SL.Add( Prefix + AName + '.Down_ColorOuter := '+Int2str(Styles.fPSDown.fColorOuter)+';'); + if Styles.fPSDis.fColorOuter <> DefStyles.fPSDis.fColorOuter then + SL.Add( Prefix + AName + '.Dis_ColorOuter := '+Int2str(Styles.fPSDis.fColorOuter)+';'); + end; + + if (Styles.fPSDef.fColorText = Styles.fPSOver.fColorText) + and (Styles.fPSDef.fColorText = Styles.fPSDown.fColorText) + and (Styles.fPSDef.fColorText = Styles.fPSDis.fColorText) + and (Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText) then + SL.Add( Prefix + AName + '.All_ColorText := '+Int2str(Styles.fPSDef.fColorText)+';') + else begin + if Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText then + SL.Add( Prefix + AName + '.Def_ColorText := '+Int2str(Styles.fPSDef.fColorText)+';'); + if Styles.fPSOver.fColorText <> DefStyles.fPSOver.fColorText then + SL.Add( Prefix + AName + '.Over_ColorText := '+Int2str(Styles.fPSOver.fColorText)+';'); + if Styles.fPSDown.fColorText <> DefStyles.fPSDown.fColorText then + SL.Add( Prefix + AName + '.Down_ColorText := '+Int2str(Styles.fPSDown.fColorText)+';'); + if Styles.fPSDis.fColorText <> DefStyles.fPSDis.fColorText then + SL.Add( Prefix + AName + '.Dis_ColorText := '+Int2str(Styles.fPSDis.fColorText)+';'); + end; + + if (Styles.fPSDef.fColorShadow = Styles.fPSOver.fColorShadow) + and (Styles.fPSDef.fColorShadow = Styles.fPSDown.fColorShadow) + and (Styles.fPSDef.fColorShadow = Styles.fPSDis.fColorShadow) + and (Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow) then + SL.Add( Prefix + AName + '.All_ColorShadow := '+Int2str(Styles.fPSDef.fColorShadow)+';') + else begin + if Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow then + SL.Add( Prefix + AName + '.Def_ColorShadow := '+Int2str(Styles.fPSDef.fColorShadow)+';'); + if Styles.fPSOver.fColorShadow <> DefStyles.fPSOver.fColorShadow then + SL.Add( Prefix + AName + '.Over_ColorShadow := '+Int2str(Styles.fPSOver.fColorShadow)+';'); + if Styles.fPSDown.fColorShadow <> DefStyles.fPSDown.fColorShadow then + SL.Add( Prefix + AName + '.Down_ColorShadow := '+Int2str(Styles.fPSDown.fColorShadow)+';'); + if Styles.fPSDis.fColorShadow <> DefStyles.fPSDis.fColorShadow then + SL.Add( Prefix + AName + '.Dis_ColorShadow := '+Int2str(Styles.fPSDis.fColorShadow)+';'); + end; + + if (Styles.fPSDef.fBorderColor = Styles.fPSOver.fBorderColor) + and (Styles.fPSDef.fBorderColor = Styles.fPSDown.fBorderColor) + and (Styles.fPSDef.fBorderColor = Styles.fPSDis.fBorderColor) + and (Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor) then + SL.Add( Prefix + AName + '.All_BorderColor := '+Int2str(Styles.fPSDef.fBorderColor)+';') + else begin + if Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor then + SL.Add( Prefix + AName + '.Def_BorderColor := '+Int2str(Styles.fPSDef.fBorderColor)+';'); + if Styles.fPSOver.fBorderColor <> DefStyles.fPSOver.fBorderColor then + SL.Add( Prefix + AName + '.Over_BorderColor := '+Int2str(Styles.fPSOver.fBorderColor)+';'); + if Styles.fPSDown.fBorderColor <> DefStyles.fPSDown.fBorderColor then + SL.Add( Prefix + AName + '.Down_BorderColor := '+Int2str(Styles.fPSDown.fBorderColor)+';'); + if Styles.fPSDis.fBorderColor <> DefStyles.fPSDis.fBorderColor then + SL.Add( Prefix + AName + '.Dis_BorderColor := '+Int2str(Styles.fPSDis.fBorderColor)+';'); + end; + + if (Styles.fPSDef.fBorderRoundWidth = Styles.fPSOver.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDown.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDis.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth) then + SL.Add( Prefix + AName + '.All_BorderRoundWidth := '+Int2Str(Styles.fPSDef.fBorderRoundWidth)+';') + else begin + if Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Def_BorderRoundWidth := '+Int2Str(Styles.fPSDef.fBorderRoundWidth)+';'); + if Styles.fPSOver.fBorderRoundWidth <> DefStyles.fPSOver.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Over_BorderRoundWidth := '+Int2Str(Styles.fPSOver.fBorderRoundWidth)+';'); + if Styles.fPSDown.fBorderRoundWidth <> DefStyles.fPSDown.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Down_BorderRoundWidth := '+Int2Str(Styles.fPSDown.fBorderRoundWidth)+';'); + if Styles.fPSDis.fBorderRoundWidth <> DefStyles.fPSDis.fBorderRoundWidth then + SL.Add( Prefix + AName + '.Dis_BorderRoundWidth := '+Int2Str(Styles.fPSDis.fBorderRoundWidth)+';'); + end; + + if (Styles.fPSDef.fBorderRoundHeight = Styles.fPSOver.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDown.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDis.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight) then + SL.Add( Prefix + AName + '.All_BorderRoundHeight := '+Int2Str(Styles.fPSDef.fBorderRoundHeight)+';') + else begin + if Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Def_BorderRoundHeight := '+Int2Str(Styles.fPSDef.fBorderRoundHeight)+';'); + if Styles.fPSOver.fBorderRoundHeight <> DefStyles.fPSOver.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Over_BorderRoundHeight := '+Int2Str(Styles.fPSOver.fBorderRoundHeight)+';'); + if Styles.fPSDown.fBorderRoundHeight <> DefStyles.fPSDown.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Down_BorderRoundHeight := '+Int2Str(Styles.fPSDown.fBorderRoundHeight)+';'); + if Styles.fPSDis.fBorderRoundHeight <> DefStyles.fPSDis.fBorderRoundHeight then + SL.Add( Prefix + AName + '.Dis_BorderRoundHeight := '+Int2Str(Styles.fPSDis.fBorderRoundHeight)+';'); + end; + + if (Styles.fPSDef.fBorderWidth = Styles.fPSOver.fBorderWidth) + and (Styles.fPSDef.fBorderWidth = Styles.fPSDown.fBorderWidth) + and (Styles.fPSDef.fBorderWidth = Styles.fPSDis.fBorderWidth) + and (Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth) then + SL.Add( Prefix + AName + '.All_BorderWidth := '+Int2Str(Styles.fPSDef.fBorderWidth)+';') + else begin + if Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth then + SL.Add( Prefix + AName + '.Def_BorderWidth := '+Int2Str(Styles.fPSDef.fBorderWidth)+';'); + if Styles.fPSOver.fBorderWidth <> DefStyles.fPSOver.fBorderWidth then + SL.Add( Prefix + AName + '.Over_BorderWidth := '+Int2Str(Styles.fPSOver.fBorderWidth)+';'); + if Styles.fPSDown.fBorderWidth <> DefStyles.fPSDown.fBorderWidth then + SL.Add( Prefix + AName + '.Down_BorderWidth := '+Int2Str(Styles.fPSDown.fBorderWidth)+';'); + if Styles.fPSDis.fBorderWidth <> DefStyles.fPSDis.fBorderWidth then + SL.Add( Prefix + AName + '.Dis_BorderWidth := '+Int2Str(Styles.fPSDis.fBorderWidth)+';'); + end; + + if (Styles.fPSDef.fGradientStyle = Styles.fPSOver.fGradientStyle) + and (Styles.fPSDef.fGradientStyle = Styles.fPSDown.fGradientStyle) + and (Styles.fPSDef.fGradientStyle = Styles.fPSDis.fGradientStyle) + and (Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle) then + SL.Add( Prefix + AName + '.All_GradientStyle := '+GradientStyles[Styles.fPSDef.fGradientStyle]+';') + else begin + if Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle then + SL.Add( Prefix + AName + '.Def_GradientStyle := '+GradientStyles[Styles.fPSDef.fGradientStyle]+';'); + if Styles.fPSOver.fGradientStyle <> DefStyles.fPSOver.fGradientStyle then + SL.Add( Prefix + AName + '.Over_GradientStyle := '+GradientStyles[Styles.fPSOver.fGradientStyle]+';'); + if Styles.fPSDown.fGradientStyle <> DefStyles.fPSDown.fGradientStyle then + SL.Add( Prefix + AName + '.Down_GradientStyle := '+GradientStyles[Styles.fPSDown.fGradientStyle]+';'); + if Styles.fPSDis.fGradientStyle <> DefStyles.fPSDis.fGradientStyle then + SL.Add( Prefix + AName + '.Dis_GradientStyle := '+GradientStyles[Styles.fPSDis.fGradientStyle]+';'); + end; + + if (Styles.fPSDef.fShadowOffset = Styles.fPSOver.fShadowOffset) + and (Styles.fPSDef.fShadowOffset = Styles.fPSDown.fShadowOffset) + and (Styles.fPSDef.fShadowOffset = Styles.fPSDis.fShadowOffset) + and (Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset) then + SL.Add( Prefix + AName + '.All_ShadowOffset := '+Int2Str(Styles.fPSDef.fShadowOffset)+';') + else begin + if Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset then + SL.Add( Prefix + AName + '.Def_ShadowOffset := '+Int2Str(Styles.fPSDef.fShadowOffset)+';'); + if Styles.fPSOver.fShadowOffset <> DefStyles.fPSOver.fShadowOffset then + SL.Add( Prefix + AName + '.Over_ShadowOffset := '+Int2Str(Styles.fPSOver.fShadowOffset)+';'); + if Styles.fPSDown.fShadowOffset <> DefStyles.fPSDown.fShadowOffset then + SL.Add( Prefix + AName + '.Down_ShadowOffset := '+Int2Str(Styles.fPSDown.fShadowOffset)+';'); + if Styles.fPSDis.fShadowOffset <> DefStyles.fPSDis.fShadowOffset then + SL.Add( Prefix + AName + '.Dis_ShadowOffset := '+Int2Str(Styles.fPSDis.fShadowOffset)+';'); + end; + + if (Styles.fPSDef.fGlyphItemX = Styles.fPSOver.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX = Styles.fPSDown.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX = Styles.fPSDis.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX) then + SL.Add( Prefix + AName + '.All_GlyphItemX := '+Int2Str(Styles.fPSDef.fGlyphItemX)+';') + else begin + if Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX then + SL.Add( Prefix + AName + '.Def_GlyphItemX := '+Int2Str(Styles.fPSDef.fGlyphItemX)+';'); + if Styles.fPSOver.fGlyphItemX <> DefStyles.fPSOver.fGlyphItemX then + SL.Add( Prefix + AName + '.Over_GlyphItemX := '+Int2Str(Styles.fPSOver.fGlyphItemX)+';'); + if Styles.fPSDown.fGlyphItemX <> DefStyles.fPSDown.fGlyphItemX then + SL.Add( Prefix + AName + '.Down_GlyphItemX := '+Int2Str(Styles.fPSDown.fGlyphItemX)+';'); + if Styles.fPSDis.fGlyphItemX <> DefStyles.fPSDis.fGlyphItemX then + SL.Add( Prefix + AName + '.Dis_GlyphItemX := '+Int2Str(Styles.fPSDis.fGlyphItemX)+';'); + end; + + if (Styles.fPSDef.fGlyphItemY = Styles.fPSOver.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY = Styles.fPSDown.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY = Styles.fPSDis.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY) then + SL.Add( Prefix + AName + '.All_GlyphItemY := '+Int2Str(Styles.fPSDef.fGlyphItemY)+';') + else begin + if Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY then + SL.Add( Prefix + AName + '.Def_GlyphItemY := '+Int2Str(Styles.fPSDef.fGlyphItemY)+';'); + if Styles.fPSOver.fGlyphItemY <> DefStyles.fPSOver.fGlyphItemY then + SL.Add( Prefix + AName + '.Over_GlyphItemY := '+Int2Str(Styles.fPSOver.fGlyphItemY)+';'); + if Styles.fPSDown.fGlyphItemY <> DefStyles.fPSDown.fGlyphItemY then + SL.Add( Prefix + AName + '.Down_GlyphItemY := '+Int2Str(Styles.fPSDown.fGlyphItemY)+';'); + if Styles.fPSDis.fGlyphItemY <> DefStyles.fPSDis.fGlyphItemY then + SL.Add( Prefix + AName + '.Dis_GlyphItemY := '+Int2Str(Styles.fPSDis.fGlyphItemY)+';'); + end; +end; + +procedure P_SetUpState4States (aOwner: TComponent; Styles: TKOLGrushStyles; + SL: TStringList; DefStyles: TKOLGrushStyles); +begin + if (Styles.fPSDef.fColorFrom = Styles.fPSOver.fColorFrom) + and (Styles.fPSDef.fColorFrom = Styles.fPSDown.fColorFrom) + and (Styles.fPSDef.fColorFrom = Styles.fPSDis.fColorFrom) + and (Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorFrom ) + ') C1 GR0O_.SetAll_ColorFrom<2>' ) + else begin + if Styles.fPSDef.fColorFrom <> DefStyles.fPSDef.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorFrom ) + ') C1 GR0O_.SetDef_ColorFrom<2>' ); + if Styles.fPSOver.fColorFrom <> DefStyles.fPSOver.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fColorFrom ) + ') C1 GR0O_.SetOver_ColorFrom<2>' ); + if Styles.fPSDown.fColorFrom <> DefStyles.fPSDown.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorFrom ) + ') C1 GR0O_.SetDown_ColorFrom<2>' ); + if Styles.fPSDis.fColorFrom <> DefStyles.fPSDis.fColorFrom then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fColorFrom ) + ') C1 GR0O_.SetDis_ColorFrom<2>' ); + end; + + if (Styles.fPSDef.fColorTo = Styles.fPSOver.fColorTo) + and (Styles.fPSDef.fColorTo = Styles.fPSDown.fColorTo) + and (Styles.fPSDef.fColorTo = Styles.fPSDis.fColorTo) + and (Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorTo ) + ') C1 GR0O_.SetAll_ColorTo<2>' ) + else begin + if Styles.fPSDef.fColorTo <> DefStyles.fPSDef.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorTo ) + ') C1 GR0O_.SetDef_ColorTo<2>' ); + if Styles.fPSOver.fColorTo <> DefStyles.fPSOver.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fColorTo ) + ') C1 GR0O_.SetOver_ColorTo<2>' ); + if Styles.fPSDown.fColorTo <> DefStyles.fPSDown.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorTo ) + ') C1 GR0O_.SetDown_ColorTo<2>' ); + if Styles.fPSDis.fColorTo <> DefStyles.fPSDis.fColorTo then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fColorTo ) + ') C1 GR0O_.SetDis_ColorTo<2>' ); + end; + + if (Styles.fPSDef.fColorOuter = Styles.fPSOver.fColorOuter) + and (Styles.fPSDef.fColorOuter = Styles.fPSDown.fColorOuter) + and (Styles.fPSDef.fColorOuter = Styles.fPSDis.fColorOuter) + and (Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorOuter ) + ') C1 GR0O_.SetAll_ColorOuter<2>' ) + else begin + if Styles.fPSDef.fColorOuter <> DefStyles.fPSDef.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorOuter ) + ') C1 GR0O_.SetDef_ColorOuter<2>' ); + if Styles.fPSOver.fColorOuter <> DefStyles.fPSOver.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fColorOuter ) + ') C1 GR0O_.SetOver_ColorOuter<2>' ); + if Styles.fPSDown.fColorOuter <> DefStyles.fPSDown.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorOuter ) + ') C1 GR0O_.SetDown_ColorOuter<2>' ); + if Styles.fPSDis.fColorOuter <> DefStyles.fPSDis.fColorOuter then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fColorOuter ) + ') C1 GR0O_.SetDis_ColorOuter<2>' ); + end; + + if (Styles.fPSDef.fColorText = Styles.fPSOver.fColorText) + and (Styles.fPSDef.fColorText = Styles.fPSDown.fColorText) + and (Styles.fPSDef.fColorText = Styles.fPSDis.fColorText) + and (Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorText ) + ') C1 GR0O_.SetAll_ColorText<2>' ) + else begin + if Styles.fPSDef.fColorText <> DefStyles.fPSDef.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorText ) + ') C1 GR0O_.SetDef_ColorText<2>' ); + if Styles.fPSOver.fColorText <> DefStyles.fPSOver.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fColorText ) + ') C1 GR0O_.SetOver_ColorText<2>' ); + if Styles.fPSDown.fColorText <> DefStyles.fPSDown.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorText ) + ') C1 GR0O_.SetDown_ColorText<2>' ); + if Styles.fPSDis.fColorText <> DefStyles.fPSDis.fColorText then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fColorText ) + ') C1 GR0O_.SetDis_ColorText<2>' ); + end; + + if (Styles.fPSDef.fColorShadow = Styles.fPSOver.fColorShadow) + and (Styles.fPSDef.fColorShadow = Styles.fPSDown.fColorShadow) + and (Styles.fPSDef.fColorShadow = Styles.fPSDis.fColorShadow) + and (Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorShadow ) + ') C1 GR0O_.SetAll_ColorShadow<2>' ) + else begin + if Styles.fPSDef.fColorShadow <> DefStyles.fPSDef.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fColorShadow ) + ') C1 GR0O_.SetDef_ColorShadow<2>' ); + if Styles.fPSOver.fColorShadow <> DefStyles.fPSOver.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fColorShadow ) + ') C1 GR0O_.SetOver_ColorShadow<2>' ); + if Styles.fPSDown.fColorShadow <> DefStyles.fPSDown.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fColorShadow ) + ') C1 GR0O_.SetDown_ColorShadow<2>' ); + if Styles.fPSDis.fColorShadow <> DefStyles.fPSDis.fColorShadow then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fColorShadow ) + ') C1 GR0O_.SetDis_ColorShadow<2>' ); + end; + + if (Styles.fPSDef.fBorderColor = Styles.fPSOver.fBorderColor) + and (Styles.fPSDef.fBorderColor = Styles.fPSDown.fBorderColor) + and (Styles.fPSDef.fBorderColor = Styles.fPSDis.fBorderColor) + and (Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderColor ) + ') C1 GR0O_.SetAll_BorderColor<2>' ) + else begin + if Styles.fPSDef.fBorderColor <> DefStyles.fPSDef.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderColor ) + ') C1 GR0O_.SetDef_BorderColor<2>' ); + if Styles.fPSOver.fBorderColor <> DefStyles.fPSOver.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fBorderColor ) + ') C1 GR0O_.SetOver_BorderColor<2>' ); + if Styles.fPSDown.fBorderColor <> DefStyles.fPSDown.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderColor ) + ') C1 GR0O_.SetDown_BorderColor<2>' ); + if Styles.fPSDis.fBorderColor <> DefStyles.fPSDis.fBorderColor then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fBorderColor ) + ') C1 GR0O_.SetDis_BorderColor<2>' ); + end; + + if (Styles.fPSDef.fBorderRoundWidth = Styles.fPSOver.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDown.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth = Styles.fPSDis.fBorderRoundWidth) + and (Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundWidth ) + ') C1 GR0O_.SetAll_BorderRoundWidth<2>' ) + else begin + if Styles.fPSDef.fBorderRoundWidth <> DefStyles.fPSDef.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundWidth ) + ') C1 GR0O_.SetDef_BorderRoundWidth<2>' ); + if Styles.fPSOver.fBorderRoundWidth <> DefStyles.fPSOver.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fBorderRoundWidth ) + ') C1 GR0O_.SetOver_BorderRoundWidth<2>' ); + if Styles.fPSDown.fBorderRoundWidth <> DefStyles.fPSDown.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderRoundWidth ) + ') C1 GR0O_.SetDown_BorderRoundWidth<2>' ); + if Styles.fPSDis.fBorderRoundWidth <> DefStyles.fPSDis.fBorderRoundWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fBorderRoundWidth ) + ') C1 GR0O_.SetDis_BorderRoundWidth<2>' ); + end; + + if (Styles.fPSDef.fBorderRoundHeight = Styles.fPSOver.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDown.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight = Styles.fPSDis.fBorderRoundHeight) + and (Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundHeight ) + ') C1 GR0O_.SetAll_BorderRoundHeight<2>' ) + else begin + if Styles.fPSDef.fBorderRoundHeight <> DefStyles.fPSDef.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderRoundHeight ) + ') C1 GR0O_.SetDef_BorderRoundHeight<2>' ); + if Styles.fPSOver.fBorderRoundHeight <> DefStyles.fPSOver.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fBorderRoundHeight ) + ') C1 GR0O_.SetOver_BorderRoundHeight<2>' ); + if Styles.fPSDown.fBorderRoundHeight <> DefStyles.fPSDown.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderRoundHeight ) + ') C1 GR0O_.SetDown_BorderRoundHeight<2>' ); + if Styles.fPSDis.fBorderRoundHeight <> DefStyles.fPSDis.fBorderRoundHeight then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fBorderRoundHeight ) + ') C1 GR0O_.SetDis_BorderRoundHeight<2>' ); + end; + + if (Styles.fPSDef.fBorderWidth = Styles.fPSOver.fBorderWidth) + and (Styles.fPSDef.fBorderWidth = Styles.fPSDown.fBorderWidth) + and (Styles.fPSDef.fBorderWidth = Styles.fPSDis.fBorderWidth) + and (Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderWidth ) + ') C1 GR0O_.SetAll_BorderWidth<2>' ) + else begin + if Styles.fPSDef.fBorderWidth <> DefStyles.fPSDef.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fBorderWidth ) + ') C1 GR0O_.SetDef_BorderWidth<2>' ); + if Styles.fPSOver.fBorderWidth <> DefStyles.fPSOver.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fBorderWidth ) + ') C1 GR0O_.SetOver_BorderWidth<2>' ); + if Styles.fPSDown.fBorderWidth <> DefStyles.fPSDown.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fBorderWidth ) + ') C1 GR0O_.SetDown_BorderWidth<2>' ); + if Styles.fPSDis.fBorderWidth <> DefStyles.fPSDis.fBorderWidth then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fBorderWidth ) + ') C1 GR0O_.SetDis_BorderWidth<2>' ); + end; + + if (Styles.fPSDef.fGradientStyle = Styles.fPSOver.fGradientStyle) + and (Styles.fPSDef.fGradientStyle = Styles.fPSDown.fGradientStyle) + and (Styles.fPSDef.fGradientStyle = Styles.fPSDis.fGradientStyle) + and (Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle) then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDef.fGradientStyle ) ) + ') C1 GR0O_.SetAll_GradientStyle<2>' ) + else begin + if Styles.fPSDef.fGradientStyle <> DefStyles.fPSDef.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDef.fGradientStyle ) ) + ') C1 GR0O_.SetDef_GradientStyle<2>' ); + if Styles.fPSOver.fGradientStyle <> DefStyles.fPSOver.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSOver.fGradientStyle ) ) + ') C1 GR0O_.SetOver_GradientStyle<2>' ); + if Styles.fPSDown.fGradientStyle <> DefStyles.fPSDown.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDown.fGradientStyle ) ) + ') C1 GR0O_.SetDown_GradientStyle<2>' ); + if Styles.fPSDis.fGradientStyle <> DefStyles.fPSDis.fGradientStyle then + SL.Add( ' L(' + IntToStr( Byte (Styles.fPSDis.fGradientStyle ) ) + ') C1 GR0O_.SetDis_GradientStyle<2>' ); + end; + + if (Styles.fPSDef.fShadowOffset = Styles.fPSOver.fShadowOffset) + and (Styles.fPSDef.fShadowOffset = Styles.fPSDown.fShadowOffset) + and (Styles.fPSDef.fShadowOffset = Styles.fPSDis.fShadowOffset) + and (Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fShadowOffset ) + ') C1 GR0O_.SetAll_ShadowOffset<2>' ) + else begin + if Styles.fPSDef.fShadowOffset <> DefStyles.fPSDef.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fShadowOffset ) + ') C1 GR0O_.SetDef_ShadowOffset<2>' ); + if Styles.fPSOver.fShadowOffset <> DefStyles.fPSOver.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fShadowOffset ) + ') C1 GR0O_.SetOver_ShadowOffset<2>' ); + if Styles.fPSDown.fShadowOffset <> DefStyles.fPSDown.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fShadowOffset ) + ') C1 GR0O_.SetDown_ShadowOffset<2>' ); + if Styles.fPSDis.fShadowOffset <> DefStyles.fPSDis.fShadowOffset then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fShadowOffset ) + ') C1 GR0O_.SetDis_ShadowOffset<2>' ); + end; + + if (Styles.fPSDef.fGlyphItemX = Styles.fPSOver.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX = Styles.fPSDown.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX = Styles.fPSDis.fGlyphItemX) + and (Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemX ) + ') C1 GR0O_.SetAll_GlyphItemX<2>' ) + else begin + if Styles.fPSDef.fGlyphItemX <> DefStyles.fPSDef.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemX ) + ') C1 GR0O_.SetDef_GlyphItemX<2>' ); + if Styles.fPSOver.fGlyphItemX <> DefStyles.fPSOver.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fGlyphItemX ) + ') C1 GR0O_.SetOver_GlyphItemX<2>' ); + if Styles.fPSDown.fGlyphItemX <> DefStyles.fPSDown.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fGlyphItemX ) + ') C1 GR0O_.SetDown_GlyphItemX<2>' ); + if Styles.fPSDis.fGlyphItemX <> DefStyles.fPSDis.fGlyphItemX then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fGlyphItemX ) + ') C1 GR0O_.SetDis_GlyphItemX<2>' ); + end; + + if (Styles.fPSDef.fGlyphItemY = Styles.fPSOver.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY = Styles.fPSDown.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY = Styles.fPSDis.fGlyphItemY) + and (Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY) then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemY ) + ') C1 GR0O_.SetAll_GlyphItemY<2>' ) + else begin + if Styles.fPSDef.fGlyphItemY <> DefStyles.fPSDef.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSDef.fGlyphItemY ) + ') C1 GR0O_.SetDef_GlyphItemY<2>' ); + if Styles.fPSOver.fGlyphItemY <> DefStyles.fPSOver.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSOver.fGlyphItemY ) + ') C1 GR0O_.SetOver_GlyphItemY<2>' ); + if Styles.fPSDown.fGlyphItemY <> DefStyles.fPSDown.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSDown.fGlyphItemY ) + ') C1 GR0O_.SetDown_GlyphItemY<2>' ); + if Styles.fPSDis.fGlyphItemY <> DefStyles.fPSDis.fGlyphItemY then + SL.Add( ' L(' + IntToStr( Styles.fPSDis.fGlyphItemY ) + ') C1 GR0O_.SetDis_GlyphItemY<2>' ); + end; +end; + + + {if fStyles.fGlyphWidth <> CtlStyles.fGlyphWidth then + SL.Add( Prefix + AName + '.All_GlyphWidth := '+int2str(fStyles.GlyphWidth)+';'); + if fStyles.fGlyphHeight <> CtlStyles.fGlyphHeight then + SL.Add( Prefix + AName + '.All_GlyphHeight := '+int2str(fStyles.GlyphHeight)+';'); + if fStyles.fCheckMetric <> CtlStyles.fCheckMetric then + SL.Add( Prefix + AName + '.All_CheckMetric := '+int2str(fStyles.CheckMetric)+';'); + if fStyles.fColorCheck <> CtlStyles.fColorCheck then + SL.Add( Prefix + AName + '.All_ColorCheck := $'+Int2Hex(fStyles.ColorCheck, 6)+';'); + if fStyles.GlyphVAlign <> CtlStyles.fGlyphVAlign then + SL.Add( Prefix + AName + '.All_GlyphVAlign := '+TVAligns[fStyles.GlyphVAlign]+';'); + if fStyles.GlyphHAlign <> CtlStyles.fGlyphHAlign then + SL.Add( Prefix + AName + '.All_GlyphHAlign := '+THAligns[fStyles.GlyphHAlign]+';'); + if fStyles.TextVAlign <> CtlStyles.TextVAlign then + SL.Add( Prefix + AName + '.All_TextVAlign := '+TVAligns[fStyles.TextVAlign]+';'); + if fStyles.TextHAlign <> CtlStyles.TextHAlign then + SL.Add( Prefix + AName + '.All_TextHAlign := '+THAligns[fStyles.TextHAlign]+';'); + if fStyles.DrawGlyph <> CtlStyles.DrawGlyph then + SL.Add( Prefix + AName + '.All_DrawGlyph := '+Booleans[fStyles.DrawGlyph]+';'); + if fStyles.DrawText <> CtlStyles.DrawText then + SL.Add( Prefix + AName + '.All_DrawText := '+Booleans[fStyles.DrawText]+';'); + if fStyles.DrawFocusRect <> CtlStyles.DrawFocusRect then + SL.Add( Prefix + AName + '.All_DrawFocusRect := '+Booleans[fStyles.DrawFocusRect]+';'); + if fStyles.DrawProgress <> CtlStyles.DrawProgress then + SL.Add( Prefix + AName + '.All_DrawProgress := '+Booleans[fStyles.DrawProgress]+';'); + if fStyles.DrawProgressRect <> CtlStyles.DrawProgressRect then + SL.Add( Prefix + AName + '.All_DrawProgressRect := '+Booleans[fStyles.DrawProgressRect]+';'); + if fStyles.GlyphAttached <> CtlStyles.GlyphAttached then + SL.Add( Prefix + AName + '.All_GlyphAttached := '+Booleans[fStyles.GlyphAttached]+';'); + if fStyles.CropTopFirst <> CtlStyles.CropTopFirst then + SL.Add( Prefix + AName + '.All_CropTopFirst := '+Booleans[fStyles.CropTopFirst]+';'); + if fStyles.AntiAliasing <> CtlStyles.AntiAliasing then + SL.Add( Prefix + AName + '.All_AntiAliasing := '+Booleans[fStyles.AntiAliasing]+';'); + if fStyles.ProgressVertical <> CtlStyles.ProgressVertical then + SL.Add( Prefix + AName + '.All_ProgressVertical := '+Booleans[fStyles.ProgressVertical]+';'); + if fStyles.UpdateSpeed <> CtlStyles.UpdateSpeed then + SL.Add( Prefix + AName + '.All_UpdateSpeed := '+TGRushSpeeds[fStyles.UpdateSpeed]+';'); + if fStyles.Spacing <> CtlStyles.Spacing then + SL.Add( Prefix + AName + '.All_Spacing := '+int2str(fStyles.Spacing)+';');} + +procedure GenerateCustomResource( Resource: Classes.TStream; const FileName: String; + const ResName: string; ResType: PChar ); +const header: array [0..31] of char = #0#0#0#0#32#0#0#0#255#255#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0; + postheader: array [0..17] of char = #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0; +var TempStr: WideString; + OutFile: TFileStream; + I: integer; +begin + DeleteFile(FileName); + Resource.Position := 0; + OutFile := TFileStream.Create(FileName, fmCreate); + OutFile.Write(header, 32); + I := Resource.Size; + OutFile.Write(I, 4); + I := (length(ResName) + 10 + Length(ResType))*2+8; + OutFile.Write(I, 4); + TempStr := ResType; + OutFile.Write(Pointer(TempStr)^, 2*length(TempStr)); + I := 0; + OutFile.Write(I, 2); + TempStr := ResName; + OutFile.Write(Pointer(TempStr)^, 2*length(TempStr)); + OutFile.Write(postheader, 18); + OutFile.CopyFrom(Resource, Resource.Size); + OutFile.Free; +end; + + +//****************************************************************************** +// GRush ImageCollection +//****************************************************************************** + +constructor TKOLGRushImageCollection.Create; +begin + inherited; + NeedFree := FALSE; + fImageType := None; +end; + +destructor TKOLGRushImageCollection.Destroy; +begin + try + fDataStream.Free; + finally + fDataStream := nil; + end; + inherited; +end; + + +function TKOLGRushImageCollection.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +function TKOLGRushImageCollection.TypeName: String; +begin + Result := 'GRushImageCollection'; +end; + +function TKOLGRushImageCollection.GetResourceName: String; +begin + Result := UpperCase(Self.ParentForm.Name + '_' + Self.Name); +end; + +function TKOLGRushImageCollection.GetResourceFileName: String; +begin + Result := Self.ParentForm.Name + '_' + Self.Name; +end; + +procedure TKOLGRushImageCollection.SetImageType (Value: TKOLGRushImageCollectionImageType); +var OSD: KOL.POpenSaveDialog; + KOLBitmap: KOL.PBitmap; + KOLStream: KOL.PStream; + ret: DWORD; + ActiveWindow: HWnd; + WindowList: Pointer; + Ex: Boolean; +begin + if Value = fImageType then exit; + if csReading in ComponentState then begin + fImageType := Value; + exit; + end; + if fImageType <> None then begin + if Value <> None then begin + MessageBox(Self.ParentForm.Handle, 'The image type was automatically detected by the file' + + ' content and can not be changed. Select "None" first to free current image.' + , '', MB_ICONQUESTION); + exit; + end; + fImageType := Value; + try + fDataStream.Free; + except + ShowMessage('Произошла ошибка при смене типа картинки.'); + end; + fDataStream := nil; + end else {if not assigned(fDataStream) then }begin + if assigned(fDataStream) then + fDataStream.Free; + fDataStream := nil; + OSD := NewOpenSaveDialog('chose file to open', ProjectSourcePath + , [OSFileMustExist, OSHideReadonly, OSPathMustExist] ); + OSD.Filter := 'Jpeg files|*.jpg;*.jpeg|Png files|*.png|Gif files|*.gif|Bmp files|*.bmp|' + + 'All suported files|*.jpg;*.jpeg;*.png;*.gif;*.bmp|All files|*.*|'; + OSD.FilterIndex := 5; + ActiveWindow := GetActiveWindow; + WindowList := DisableTaskWindows(0); + Ex := OSD.Execute; + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + if Ex then begin + KOLStream := NewReadFileStream(OSD.Filename); + try + ret := tinyPNG.tinyLoadPNG(KOLBitmap, KOLStream); + except + ShowMessage('Произошла ошибка во время попытки декадировать файл как *.png' + + '. Пожалуста сообщите об этом автору (homm86@mail.ru) и прекрепите' + + ' проблемный файл если его размер менее мегабайта.'); + ret := tinyERROR_NotPNGFile; + end; + KOLStream.Free; + if (KOLBitmap <> nil) and (ret = tinyPNG.tinyERROR_OK) then begin + fDataStream := TMemoryStream.Create; + fDataStream.LoadFromFile(OSD.Filename); + fImageType := PNG; + end; + KOLBitmap.Free; + if not assigned(fDataStream) then begin + tinyJPGGIFBMP.tinyLoadJPGGIFBMPFile(KOLBitmap, OSD.FileName); + if (KOLBitmap <> nil) then begin + fDataStream := TMemoryStream.Create; + fDataStream.LoadFromFile(OSD.Filename); + fImageType := BMP_GIF_JPG; + end; + KOLBitmap.Free; + if not assigned(fDataStream) then begin + ShowMessage('This file format not supported.'); + end; + end; + end; + OSD.Free; + end; + Change; +end; + +procedure TKOLGRushImageCollection.SetItemWidth (Value: DWORD); +begin + fItemWidth := Value; + Change; +end; + +procedure TKOLGRushImageCollection.SetItemHeight (Value: DWORD); +begin + fItemHeight := Value; + Change; +end; + +procedure TKOLGRushImageCollection.DefineProperties(Filer: TFiler); +begin + inherited; + Filer.DefineBinaryProperty('Data', ReadData, WriteData, fImageType <> None); +end; + +procedure TKOLGRushImageCollection.ReadData(Stream: Classes.TStream); +var _t: DWORD; +begin + Stream.Read(_t, 4); + if not assigned(fDataStream) then begin + fDataStream := TMemoryStream.Create; + end; + fDataStream.Clear; + fDataStream.Position := 0; + fDataStream.CopyFrom(Stream, _t); +end; + +procedure TKOLGRushImageCollection.WriteData(Stream: Classes.TStream); +var _t: DWORD; +begin + _t := fDataStream.Size; + Stream.Write(_t, 4); + fDataStream.Position := 0; + Stream.CopyFrom(fDataStream, _t ); +end; + +function TKOLGRushImageCollection.AdditionalUnits: String; +begin + Result := ''; + if fNotifyList.Count = 0 then exit; + if fImageType = PNG then + Result := ', tinyPNG' + else if fImageType <> None then + Result := ', tinyJPGGIFBMP' +end; + +procedure TKOLGRushImageCollection.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +begin + if fNotifyList.Count = 0 then exit; + if fImageType = PNG then begin + SL.Add( Format(Prefix + 'tinyLoadPNGResource( %s, HINSTANCE, ''%s'', ''GRUSHCOLLECTIONS'');' + , [ AName, GetResourceName ] ) ); + end else if fImageType <> None then begin + SL.Add( Format(Prefix + 'tinyLoadJPGGIFBMPResource( %s, HINSTANCE, ''%s'', ''GRUSHCOLLECTIONS'');' + , [ AName, GetResourceName ] ) ); + end; + if (fImageType <> None) and assigned(fDataStream) then begin + GenerateCustomResource(fDataStream, ProjectSourcePath + GetResourceFileName + '.res' + , GetResourceName, 'GRUSHCOLLECTIONS'); + SL.Add(Prefix + '{$R '+ GetResourceFileName + '.res}'); + end; +end; + +procedure TKOLGRushImageCollection.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +begin + +end; + +procedure TKOLGRushImageCollection.SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); +begin + if fNotifyList.Count = 0 then exit; + if fImageType <> None then + SL.Add ( Prefix + AName + '.Free;' ); +end; + +procedure TKOLGRushImageCollection.P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); +begin + +end; + +procedure TKOLGRushImageCollection.AssignEvents( SL: TStringList; const AName: String ); +begin + +end; + +function TKOLGRushImageCollection.P_AssignEvents( SL: TStringList; const AName: String; + CheckOnly: Boolean ): Boolean; +begin + Result := FALSE; +end; + +procedure tinyLoadJPGGIFBMPStream(var TargetBitmap: KOL.PBitMap; Stream: Classes.TStream); +var Ptr: Pointer; +begin + DWORD(Ptr) := LocalAlloc(GMEM_FIXED, Stream.Size); + Stream.Position := 0; + Stream.Read(Ptr^, Stream.Size); + tinyLoadJPGGIFBMPMemory(TargetBitmap, DWORD(Ptr), Stream.Size); +end; + +function TKOLGRushImageCollection.LoadBitmap: PBitmap; +var KOLStream: KOL.PStream; +begin + Result := nil; + if fImageType <> None then begin + if fImageType = PNG then begin + KOLStream := NewExMemoryStream(fDataStream.Memory, fDataStream.Size); + try + tinyLoadPNG(Result, KOLStream); + except + ShowMessage('Произошла ошибка во время попытки декадировать файл как *.png' + + '. Пожалуста сообщите об этом автору (homm86@mail.ru) и прекрепите' + + ' проблемный файл если его размер менее мегабайта.'); + try + Result.Free; + finally + Result := nil; + end; + end; + KOLStream.Free; + if Result = nil then begin + ShowMessage('Компонент должен хранить картинку в формате PNG, но из-за ошибки' + + ' компонента она не может быть прочитана.'); + end; + end else begin + tinyLoadJPGGIFBMPStream(Result, fDataStream); + if Result = nil then begin + ShowMessage('Компонент должен хранить картинку в формате BMP_GIF_JPG, но' + + ' из-за ошибки компонента она не может быть прочитана.'); + end; + end; + end; +end; + +//****************************************************************************** +// GRush Button +//****************************************************************************** + +constructor TKOLGRushButton.Create(AOwner: TComponent); +begin + inherited; + fStyles := TKOLGRushButtonStyles.Create(Self); + fAutoSzX := 12; + fAutoSzY := 11; +end; + +destructor TKOLGRushButton.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushButton.SetStyles(Val: TKOLGRushButtonStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushButton.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +procedure TKOLGRushButton.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushButton.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +function TKOLGRushButton.DefaultParentColor; +begin + Result := TRUE; +end; +function TKOLGRushButton.CanChangeColor; +begin + Result := TRUE; +end; +function TKOLGRushButton.CanNotChangeFontColor; +begin + Result := FALSE; +end; +procedure TKOLGRushButton.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +function TKOLGRushButton.TypeName: String; +begin + Result := 'GRushButton'; +end; + +function TKOLGRushButton.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +procedure TKOLGRushButton.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushButton(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + +procedure TKOLGRushButton.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushButtonStyles; +begin + inherited; + CtlStyles := TKOLGrushButtonStyles.Create( Self ); + SetUpState4States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + if fStyles.DrawFocusRect <> CtlStyles.DrawFocusRect then + SL.Add( Prefix + AName + '.All_DrawFocusRect := '+Booleans[fStyles.DrawFocusRect]+';'); + if fStyles.UpdateSpeed <> CtlStyles.UpdateSpeed then + SL.Add( Prefix + AName + '.All_UpdateSpeed := '+TGRushSpeeds[fStyles.UpdateSpeed]+';'); + + CtlStyles.Free; +end; + +procedure TKOLGRushButton.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushButtonStyles; +begin + inherited; + CtlStyles := TKOLGrushButtonStyles.Create( Self ); + P_SetUpState4States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + + if fStyles.fDrawFocusRect <> CtlStyles.fDrawFocusRect then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawFocusRect<2>' ); + if fStyles.fUpdateSpeed <> CtlStyles.fUpdateSpeed then + SL.Add( ' L(' + int2str( Byte ( fStyles.fUpdateSpeed ) ) + ') C1 GR0O_.SetAll_UpdateSpeed<2>' ); + + CtlStyles.Free; +end; + +procedure TKOLGRushButton.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnRecalcRects' ], [ @fOnRecalcRects ] ); +end; + +function TKOLGRushButton.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); +end; + +//****************************************************************************** +// GRush Panel +//****************************************************************************** + +constructor TKOLGRushPanel.Create(AOwner: TComponent); +begin + inherited; + fStyles := TKOLGRushPanelStyles.Create( Self ); +end; + +destructor TKOLGRushPanel.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushPanel.SetStyles(Val: TKOLGRushPanelStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushPanel.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +procedure TKOLGRushPanel.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushPanel.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +procedure TKOLGRushPanel.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +function TKOLGRushPanel.ClientMargins; +begin + Result := MakeRect(0, 0, 0, 0); +end; + +function TKOLGRushPanel.TypeName: String; +begin + Result := 'GRushPanel'; +end; + +function TKOLGRushPanel.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +function TKOLGRushPanel.SetupParams(const AName, AParent: String): String; +begin + Result := AParent; +end; + +function TKOLGRushPanel.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; +begin + nparams := 1; + Result := ' DUP '; +end; + +procedure TKOLGRushPanel.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushPanel(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + + +procedure TKOLGRushPanel.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +var CtlStyles: TKOLGrushPanelStyles; +begin + inherited; + CtlStyles := TKOLGrushPanelStyles.Create( Self ); + SetUpState2States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + CtlStyles.Free; +end; + +procedure TKOLGRushPanel.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +var CtlStyles: TKOLGrushPanelStyles; +begin + inherited; + CtlStyles := TKOLGrushPanelStyles.Create( Self ); + P_SetUpState2States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + + CtlStyles.Free; +end; + +procedure TKOLGRushPanel.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnRecalcRects' ], [ @fOnRecalcRects ] ); +end; + +function TKOLGRushPanel.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); +end; + +//****************************************************************************** +// GRush Check Box +//****************************************************************************** + +constructor TKOLGRushCheckBox.Create(AOwner: TComponent); +begin + inherited; + fStyles := TKOLGRushCheckBoxStyles.Create( Self ); +end; + +destructor TKOLGRushCheckBox.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushCheckBox.SetStyles(Val: TKOLGRushCheckBoxStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushCheckBox.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +{procedure TKOLGRushCheckBox.P_DoProvideFakeType( SL: TStringList ); +begin + P_ProvideFakeType(SL, ' GR0O_ = object( TGRushControl ) end; '); +end; } + +procedure TKOLGRushCheckBox.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +procedure TKOLGRushCheckBox.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushCheckBox.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +function TKOLGRushCheckBox.TypeName: String; +begin + Result := 'GRushCheckBox'; +end; + +function TKOLGRushCheckBox.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +procedure TKOLGRushCheckBox.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushCheckBox(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + +procedure TKOLGRushCheckBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushCheckBoxStyles; +begin + inherited; + CtlStyles := TKOLGRushCheckBoxStyles.Create( Self ); + SetUpState4States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + if fStyles.fCheckMetric <> CtlStyles.fCheckMetric then + SL.Add( Prefix + AName + '.All_CheckMetric := '+int2str(fStyles.CheckMetric)+';'); + if fStyles.fColorCheck <> CtlStyles.fColorCheck then + SL.Add( Prefix + AName + '.All_ColorCheck := '+Int2str(fStyles.ColorCheck)+';'); + if fStyles.DrawFocusRect <> CtlStyles.DrawFocusRect then + SL.Add( Prefix + AName + '.All_DrawFocusRect := '+Booleans[fStyles.DrawFocusRect]+';'); + if fStyles.UpdateSpeed <> CtlStyles.UpdateSpeed then + SL.Add( Prefix + AName + '.All_UpdateSpeed := '+TGRushSpeeds[fStyles.UpdateSpeed]+';'); + + CtlStyles.Free; +end; + +procedure TKOLGRushCheckBox.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushRadioBoxStyles; +begin + inherited; + CtlStyles := TKOLGrushRadioBoxStyles.Create( Self ); + P_SetUpState4States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + if fStyles.fCheckMetric <> CtlStyles.fCheckMetric then + SL.Add( ' L(' + int2str( fStyles.fCheckMetric ) + ') C1 GR0O_.SetAll_CheckMetric<2>' ); + if fStyles.fColorCheck <> CtlStyles.fColorCheck then + SL.Add( ' L(' + int2str( fStyles.fColorCheck ) + ') C1 GR0O_.SetAll_ColorCheck<2>' ); + if fStyles.fDrawFocusRect <> CtlStyles.fDrawFocusRect then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawFocusRect<2>' ); + if fStyles.fUpdateSpeed <> CtlStyles.fUpdateSpeed then + SL.Add( ' L(' + int2str( Byte ( fStyles.fUpdateSpeed ) ) + ') C1 GR0O_.SetAll_UpdateSpeed<2>' ); + + CtlStyles.Free; +end; + +procedure TKOLGRushCheckBox.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnRecalcRects' ], [ @fOnRecalcRects ] ); +end; + +function TKOLGRushCheckBox.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); +end; + +//****************************************************************************** +// GRush Radio Box +//****************************************************************************** + +constructor TKOLGRushRadioBox.Create(AOwner: TComponent); +begin + inherited; + fStyles := TKOLGRushRadioBoxStyles.Create( Self ); +end; + +destructor TKOLGRushRadioBox.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushRadioBox.SetStyles(Val: TKOLGRushRadioBoxStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushRadioBox.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +{procedure TKOLGRushRadioBox.P_DoProvideFakeType( SL: TStringList ); +begin + P_ProvideFakeType(SL, ' GR0O_ = object( TGRushControl ) end; '); +end; } + +procedure TKOLGRushRadioBox.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +procedure TKOLGRushRadioBox.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushRadioBox.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +function TKOLGRushRadioBox.TypeName: String; +begin + Result := 'GRushRadioBox'; +end; + +function TKOLGRushRadioBox.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +procedure TKOLGRushRadioBox.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushRadioBox(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + +procedure TKOLGRushRadioBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushRadioBoxStyles; +begin + inherited; + CtlStyles := TKOLGrushRadioBoxStyles.Create( Self ); + SetUpState4States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + if fStyles.fCheckMetric <> CtlStyles.fCheckMetric then + SL.Add( Prefix + AName + '.All_CheckMetric := '+int2str(fStyles.CheckMetric)+';'); + if fStyles.fColorCheck <> CtlStyles.fColorCheck then + SL.Add( Prefix + AName + '.All_ColorCheck := '+Int2str(fStyles.ColorCheck)+';'); + if fStyles.fDrawFocusRect <> CtlStyles.fDrawFocusRect then + SL.Add( Prefix + AName + '.All_DrawFocusRect := '+Booleans[fStyles.DrawFocusRect]+';'); + if fStyles.fUpdateSpeed <> CtlStyles.fUpdateSpeed then + SL.Add( Prefix + AName + '.All_UpdateSpeed := '+TGRushSpeeds[fStyles.UpdateSpeed]+';'); + + CtlStyles.Free; +end; + +procedure TKOLGRushRadioBox.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushRadioBoxStyles; +begin + inherited; + CtlStyles := TKOLGrushRadioBoxStyles.Create( Self ); + P_SetUpState4States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + if fStyles.fCheckMetric <> CtlStyles.fCheckMetric then + SL.Add( ' L(' + int2str( fStyles.fCheckMetric ) + ') C1 GR0O_.SetAll_CheckMetric<2>' ); + if fStyles.fColorCheck <> CtlStyles.fColorCheck then + SL.Add( ' L(' + int2str( fStyles.fColorCheck ) + ') C1 GR0O_.SetAll_ColorCheck<2>' ); + if fStyles.fDrawFocusRect <> CtlStyles.fDrawFocusRect then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawFocusRect<2>' ); + if fStyles.fUpdateSpeed <> CtlStyles.fUpdateSpeed then + SL.Add( ' L(' + int2str( Byte( fStyles.fUpdateSpeed ) ) + ') C1 GR0O__.SetAll_UpdateSpeed<2>' ); + + CtlStyles.Free; +end; + +procedure TKOLGRushRadioBox.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnRecalcRects' ], [ @fOnRecalcRects ] ); +end; + +function TKOLGRushRadioBox.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); +end; + +//****************************************************************************** +// GRush Splitter +//****************************************************************************** + +constructor TKOLGRushSplitter.Create(AOwner: TComponent); +begin + fStyles := TKOLGRushSplitterStyles.Create( Self ); + inherited; +end; + +destructor TKOLGRushSplitter.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushSplitter.SetStyles(Val: TKOLGRushSplitterStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushSplitter.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +{procedure TKOLGRushSplitter.P_DoProvideFakeType( SL: TStringList ); +begin + P_ProvideFakeType(SL, ' GR0O_ = object( TGRushControl ) end; '); +end; } + +procedure TKOLGRushSplitter.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushSplitter.SetCaption; +begin + if fCaption = Value then begin + LogOK; + Exit; + end; + if action = nil then + fCaption := Value + else + fCaption := action.Caption; + {$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then + FKOLCtrl.Caption := fCaption; + {$ENDIF} + Invalidate; + Change; +end; + +procedure TKOLGRushSplitter.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +procedure TKOLGRushSplitter.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +function TKOLGRushSplitter.TypeName: String; +begin + Result := 'GRushSplitter'; +end; + +function TKOLGRushSplitter.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +procedure TKOLGRushSplitter.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushSplitter(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + +function TKOLGRushSplitter.SetupParams(const AName, AParent: String): String; +begin + Result := Format('%s, %d, %d', [AParent, MinSizePrev, MinSizeNext]); +end; + +function TKOLGRushSplitter.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; +begin + nparams := 3; + Result := ' L( ' + IntToStr( MinSizeNext ) + ')' + + #13#10' L( ' + IntToStr( MinSizePrev ) + ') ' + + #13#10' C2'; +end; + +procedure TKOLGRushSplitter.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushSplitterStyles; +begin + inherited; + CtlStyles := TKOLGrushSplitterStyles.Create( Self ); + CtlStyles.SetUpSplitterAlign(Align in [mirror.caLeft, mirror.caRight]); + SetUpState4States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + if fStyles.UpdateSpeed <> CtlStyles.UpdateSpeed then + SL.Add( Prefix + AName + '.All_UpdateSpeed := '+TGRushSpeeds[fStyles.UpdateSpeed]+';'); + if fStyles.SplitterDotsCount <> CtlStyles.SplitterDotsCount then + SL.Add( Prefix + AName + '.All_SplitterDotsCount := '+int2str(fStyles.SplitterDotsCount)+';'); + + CtlStyles.Free; +end; + +procedure TKOLGRushSplitter.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushSplitterStyles; +begin + inherited; + CtlStyles := TKOLGrushSplitterStyles.Create( Self ); + CtlStyles.SetUpSplitterAlign(Align in [mirror.caLeft, mirror.caRight]); + P_SetUpState4States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + + if fStyles.fUpdateSpeed <> CtlStyles.fUpdateSpeed then + SL.Add( ' L(' + int2str( Byte( fStyles.fUpdateSpeed ) ) + ') C1 GR0O_.SetAll_UpdateSpeed<2>' ); + if fStyles.SplitterDotsCount <> CtlStyles.SplitterDotsCount then + SL.Add( ' L(' + int2str(fStyles.SplitterDotsCount) + ') C1 GR0O_.SetAll_SplitterDotsCount<2>' ); + + CtlStyles.Free; +end; + +procedure TKOLGRushSplitter.Change; +begin + Inherited; + if fLastAlign <> Align then begin + fLastAlign := Align; + fStyles.SetUpSplitterAlign(Align in [mirror.caLeft, mirror.caRight]); + end; +end; + +procedure TKOLGRushSplitter.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnRecalcRects' ], [ @fOnRecalcRects ] ); +end; + +function TKOLGRushSplitter.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); +end; + +//****************************************************************************** +// GRush Progress Bar +//****************************************************************************** + +constructor TKOLGRushProgressBar.Create(AOwner: TComponent); +begin + inherited; + fStyles := TKOLGRushProgressBarStyles.Create( Self ); +end; + +destructor TKOLGRushProgressBar.Destroy; +begin + fStyles.Free; + inherited; +end; + +procedure TKOLGRushProgressBar.SetStyles(Val: TKOLGRushProgressBarStyles); +begin + fStyles.Assign( Val ); +end; + +function TKOLGRushProgressBar.Pcode_Generate: Boolean; +begin + Result := TRUE; +end; + +{procedure TKOLGRushProgressBar.P_DoProvideFakeType( SL: TStringList ); +begin + P_ProvideFakeType(SL, ' GR0O_ = object( TGRushControl ) end; '); +end; } + + +procedure TKOLGRushProgressBar.SetCaption; +begin + if fCaption = Value then begin + LogOK; + Exit; + end; + if action = nil then + fCaption := Value + else + fCaption := action.Caption; + {$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then + FKOLCtrl.Caption := fCaption; + {$ENDIF} + Invalidate; + Change; +end; + +procedure TKOLGRushProgressBar.SetOnRecalcRects; +begin + fOnRecalcRects := Value; + Change; +end; + +procedure TKOLGRushProgressBar.NotifyLinkedComponent(Sender: TObject; + Operation: TNotifyOperation); +begin + inherited; + if Operation = noRemoved then + fImageCollection := nil; +end; + +procedure TKOLGRushProgressBar.SetImageCollection(const Value: TKOLGRushImageCollection); +begin + if fImageCollection <> nil then + fImageCollection.NotifyLinkedComponent( Self, noRemoved ); + fImageCollection := Value; + if (Value <> nil) and (Value is TKOLGRushImageCollection) then begin + Value.AddToNotifyList( Self ); + end; + Change; +end; + +procedure TKOLGRushProgressBar.SetOnProgressChange; +begin + fOnProgressChange := Value; + Change; +end; + +function TKOLGRushProgressBar.TypeName: String; +begin + Result := 'GRushProgressBar'; +end; + +function TKOLGRushProgressBar.AdditionalUnits: String; +begin + Result := ', KOLGRushControls'; +end; + +function TKOLGRushProgressBar.SetupParams(const AName, AParent: String): String; +begin + Result := AParent; +end; + +function TKOLGRushProgressBar.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; +begin + nparams := 1; + Result := ' DUP '; +end; + +procedure TKOLGRushProgressBar.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: String); +begin + SL.Add( Format('%s%s := PGRushControl( NewGRushProgressBar(%s)%s );', + [ Prefix, AName, SetupParams( AName, AParent ), + GenerateTransparentInits ] ) ); +end; + + +procedure TKOLGRushProgressBar.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushProgressBarStyles; +begin + inherited; + CtlStyles := TKOLGrushProgressBarStyles.Create( Self ); + if fCaption <> '' then + SL.Add( Prefix + AName + '.Caption := '+StringConstant('Caption', fCaption)+';'); + if fStyles.ProgressVertical <> CtlStyles.ProgressVertical then + SL.Add( Prefix + AName + '.All_ProgressVertical := '+Booleans[fStyles.ProgressVertical]+';'); + CtlStyles.SetUpProgressVertical(fStyles.ProgressVertical); + SetUpState2States(Self, fStyles, SL, AName, Prefix, CtlStyles); + SetUpCommon(Self, fStyles, SL, AName, Prefix, CtlStyles, fImageCollection); + + if fStyles.DrawProgress <> CtlStyles.DrawProgress then + SL.Add( Prefix + AName + '.All_DrawProgress := '+Booleans[fStyles.DrawProgress]+';'); + if fStyles.DrawProgressRect <> CtlStyles.DrawProgressRect then + SL.Add( Prefix + AName + '.All_DrawProgressRect := '+Booleans[fStyles.DrawProgressRect]+';'); + + CtlStyles.Free; +end; + +procedure TKOLGRushProgressBar.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +const Booleans: array [Boolean] of String = ('FALSE', 'TRUE'); + TGRushSpeeds: array [TGRushSpeed] of String = ('usImmediately', 'usVeryFast', 'usFast', 'usNormal', 'usSlow', 'usVerySlow'); +var CtlStyles: TKOLGrushProgressBarStyles; +begin + inherited; + CtlStyles := TKOLGrushProgressBarStyles.Create( Self ); + if fCaption <> '' then begin + SL.Add( P_StringConstant('Caption', Caption) ); + SL.Add( ' C2 TControl_.SetCaption<2> DelAnsiStr' ); + end; + if fStyles.fProgressVertical <> CtlStyles.fProgressVertical then + SL.Add( ' L(1) C1 GR0O_.SetAll_ProgressVertical<2>' ); + + CtlStyles.SetUpProgressVertical(fStyles.ProgressVertical); + P_SetUpState2States(Self, fStyles, SL, CtlStyles); + P_SetUpCommon(Self, fStyles, SL, CtlStyles); + + if fStyles.fDrawProgress <> CtlStyles.fDrawProgress then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawProgress<2>' ); + if fStyles.fDrawProgressRect <> CtlStyles.fDrawProgressRect then + SL.Add( ' L(0) C1 GR0O_.SetAll_DrawProgressRect<2>' ); + + CtlStyles.Free; +end; + +procedure TKOLGRushProgressBar.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, [ 'OnProgressChange', 'OnRecalcRects' ], [ @OnProgressChange, @OnRecalcRects ] ); +end; + +function TKOLGRushProgressBar.P_AssignEvents(SL: TStringList; const AName: String; + CheckOnly: Boolean): Boolean; +begin + Result := inherited P_AssignEvents( SL, AName, CheckOnly ); + Result := Result or (@OnRecalcRects <> nil) or (@OnProgressChange <> nil); + if CheckOnly then exit; + if @OnRecalcRects <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnRecalcRects ) + #13#10' C2 GR0O_.SetOnRecalcRects<1>'); + if @OnProgressChange <> nil then + SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + + ParentForm.MethodName( @ OnProgressChange ) + #13#10' C2 GR0O_.SetOnProgressChange<1>'); +end; + +end. \ No newline at end of file diff --git a/Addons/MCKGRushControls.res b/Addons/MCKGRushControls.res new file mode 100644 index 0000000000000000000000000000000000000000..0a5bb77d23c24ee1e73b958ca255003c0b7fe432 GIT binary patch literal 11768 zcmeHN30PD|w*Cz!GU5WkeaQ&!Mx)RmZYZ`Jt7wCut+=(INhe0rlToLWxOFm0+A(S? zYC4KfTU>IL?JA;I!KGC)-ngZGifQ-Y5=9d;?R?Dp?mKmFHv)tCoNwOD``-6Bbx+l) z|C~Bix4QeDs=5sT9f&1KVG^s+tk-}+ghp(<2{o08l;SbES}Uc} zjfz%ot_N=!jCch|@KG4`2x2VLB7iO|TBH<|lZc|CA{1RM!sC+dXz=Q*SiJBfEM4?5 zBzIc%Co?kEe1QzhDr9AT3EP&hh&N&Pw$0$SZ9-1gChW=Dg1tNb1KiH-*tB6+mXj*A$QMiz6O$)>Q|}oR@Hy z_`z)_9{zA0kM7>WJu}m(R%&zCjgUblnDW=cuD{*(57uh$I+bZo?n-|ja4p?WhduFQ)OUbFG z=oGxlfIWJqV6wYj#m}$Ds4*By(P;$5t=gzAM%Bfr+P)Wc*#D0isEbkmJ28p{eRvW` zB4)%2Cd(|_$gs!Ktz&I#!K>OU9VqRXKezo03r}3}#36S;Q=*M02K{p}DuQmR_I=ba z+DnbVFxp?KX)iUN>}t}B;*^T^QjGu6y%h8RD($BlH1LMEw>O$MZ;tk@+M`qBP6&M^ z6afJN=-jz8x^(G+;BLVP4h}|m-@#D((pXzWW0HRgQYp=>Hxn~nn}N6Mzk}4)srX%! z5Alb_Ml5W&5FfVrJ>Km&8>!)`h>MFuO44LZi=T$nSZW!YhSd0(m_Bwo=FFLc`3n|c zk>6r$ptQc}daMXoi6ui!SQn6ib%E=V(Rn@A^jU+PE_v7&P=I}d_G7I&0~s;vu}Z%h zYyPkXhsPhm8GjLCn{Vay<=-0r7vxPOEi{)ePscauoAK?sHTZFr1&_X5i-%vX!?7)S zxXpi!lB0+5koH|?KRu6&n;bZQR+RThPky{x^P{M%*UiAceFk1OPN}OA+bvZC+?5eT zOjlDo!b{Cmq*M%_JyXkxL29P*8XXfCt0qwWjOhrag5iKL4EOk~>0j2>mNjmy zRyU@kCV_&PA~T3dHFVUT5LqMJRq7e0xNzf@ewNXBTm%iK_Bf@Xz0`0-QH*-II8~oK z0UgNaFp5!(eW}iv5sN$JCZqc-fDQxLIRQPZ*?ED>Y(}}o0#V@Mve_Wo1(NMl+U2$? zg~p9@3sj_~(Z1eYP3@bOmO5ywYF=1aSX!DYE%j6nl_6|iSX!7NE%kwwMF{qRBYIuIFe?n_Rnz)o#4jH=eQ&295;bJ&7p+UMlV`-bfnLcan*GPJD>He z8G3f_ir&57!a!9|3>r89;e!TY_@Ge4s0U)ya5aVxAC8eDhGTT(FeHwR$CQL-FF+GI?gGyzklOhH;o5~fa`1VgG8)2B^^{_Rt!Tfpn#5fEil0R(Hx{NoCnk5kFj>~Tv$If$ltHKJ%7Nhf!A?4>KradU%-`^izp?&G)+Y5 zJEbTaT83L6+^qZ#u3WYhpD+6iE6nLwxpDzrvy2n_%0z1-rJfbLTAN@7{(Z zd$-Bw%(*#xaU^di3Jdn*ae;Q_|+NcT8(J85L^v#SJ;z{>1t|K z!9A3RUT{Kka&lb10TW_FrfaoY1`eOb8jaLwG_8Dp(|F9Q15;hCP_uM6qz^40GGohAS>*KcrUt%YIqq1yrwI*RJ&_btR!5VDW9SBJk5^HMqX;!h-XpU&kg>9qD6d3nd-DkVBXNr!`trrrA0!b| zBBAQLM}p<|kL-xS*Vh;R{{Cpuq6O&f1Uh!?D9>V#9zD>jS1*KwgkZpc0ibWD9Ot5= zqcL{uSWKKa5p>!DyMz1+=bOvSbOCEn9}wt5;*gh7H)dbt`u6+==XLdS_W!2#Ic5TJagAjVs_BMR23NA|D;hJ<7_oNa$l}^y-UxXVsZs7Lq z+qir8E*?F4geOm);Fn*10c|-z?`_D2y+Nv@x*2%!47}`qxlc7>D|7{D-KK53_HX=l z;GpoqLn4OKx6b|Uu~q#}UAn*7t9P)fZ~w&P3a=SVMaq`-13Pu?-t(;>jVi1^d%IW> zAII<(_3L-++_gu~kwGD${RUK2Ox2AY&G6>+NztX-o4rN`hxF~2m^5XYZcIf?#mr`e z%U!(HTO)TdW%`WxxR|up86MbK=^`|2z_{e8)5pfgPWEFsbQhTn5vu5sEMzifAbctl=ADTTAZa)2ELQr9LG1 zFlI7?m{dcj;EKI$>CrOkjK*6{qC4>@0}6 z_tUFZt-`+iT{vk!g!5@8fS3 zf2BLCqq-TWn}L7T47_ZdYUCz>2`o-|5V>T-BcTZq(|NSYs0sIyRiyN^Qv5J`xs_Kl zHvvp&(nQIdc+nqli2R!alr{IKtYyn4lv>H;>qr0a^YweZDP;=MR;D(sfwpa0w`)O} zg3vlyCa@KA6{n?VLp=GM7!#YnNL zG?p8>8?zRQ+MTmP)_FY0zL|fy1J=pklaEiMMn04pkwEc9kr~9K8airCh^&$AD)kIg zT)1(MpY2}2EE>l1|85SW6Tq4~sf214zrO1VBHO>GQBfoN^`GWTq1z=Z!y7dl&>QgI;gY8x2Nc!(xNMY%*GmMvKYV_x(LujVUQf&>AheXp>H3(P_;(qgk&r z>Gf8<-lo^{dcCMOTJ%P{L2EMT>9QE~HiLmKyU}1W8psoGG&)Q=lgUUIdF9L|v)N>^ z7){6oM1T+S7Ng+`@^)!yzXeHe=Cn)KFEm>ynFl_Oi@QB%$@SUha&zC$IE~4wG265j zPESgc&1|udmBnJyTREeRGub!`XN#6BT8Yz3T#%WM%yc%(lse}~L7dc|m(+r!DVFp$ z-oWu%vpCCoLobx;1(!~g^bW~n;!P&eV&*Jn-fVW5Exg6X8*NS_&ztw>et7Km7lPB^ zkc^^aa!3}@W$hloX}SyVhuTdBo5?JhgRB;_%|b2BRvMGl!jTKJMX(atY*w3SqtTJX zSvf0D8E4};n~T>7yw%BD1>Q!eQ_xujt6i{J?G~HB*#%Ctb5;w_*?EEI?E){_d56F| z?0h-L%XWgzCh#07DYpxP-D(wWHj(2+o@@otYISg&Ll7Kx!NKuPn^4AaWr9#fE0`Q< z%+t#$lH@H(;SSLtxeP9+SrjeX9&vWbCW^d6Trr_<#uD|fo2GDhX)<*sr`a?u7=DkJX6 zegf>b0PoMS@Hg!uvonjAdi(c?_1?DSSO?#LHr>5DMV?sZ=hydm!56oVPVpU*-YzP4 z+vzo(H-GfOPf>T)Wc2X~tO&{Lk~`~^Z(!;2MiWPW8a^+*S$gh{b6X>$+Ds_PzjuDg z=&u4NwK3g0x;=1nm+wpX2dBNJ9veJAbMe=oEt%HT+-vuZABXZyo8+gon)hf_?&P0e JtB--ee*@47DE|Ne literal 0 HcmV?d00001 diff --git a/Addons/MCKGRushImageCollectionEditor.pas b/Addons/MCKGRushImageCollectionEditor.pas new file mode 100644 index 0000000..dcf3db1 --- /dev/null +++ b/Addons/MCKGRushImageCollectionEditor.pas @@ -0,0 +1,338 @@ +unit MCKGRushImageCollectionEditor; + +// file: MCKGRushImageCollectionEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +interface + +{$I KOLDEF.INC} + +uses Windows, + Messages, + ShellAPI, + KOL, + KOLGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + MCKGRushControls, + Forms, + {$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; + {$ELSE} + DsgnIntf; + {$ENDIF} + + +type + TKOLGRushImageCollectionEditor = class( TComponentEditor ) + private + protected + public + procedure Edit; override; + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): string; override; + function GetVerbCount: Integer; override; + end; + + ImageCollectionData= record + fImageType: TKOLGRushImageCollectionImageType; + fItemWidth: DWORD; + fItemHeight: DWORD; + fDataStream: TMemoryStream; + end; + + PImageCollectionEditor = ^TImageCollectionEditor; + TImageCollectionEditor = object (TObj) + Form: KOL.PControl; + ScrollBox: PControl; + ImageShow: PControl; + ButtonOK: PGRushControl; + ButtonCancel: PGRushControl; + ButtonOpen_Close: PGRushControl; + ButtonSave: PGRushControl; + OSD: KOL.POpenSaveDialog; + Collection: ImageCollectionData; + Comp: TKOLGRushImageCollection; + Bitmap: KOL.PBitmap; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + procedure OKClick(Self_: KOL.PObj); + procedure CancelClick(Self_: KOL.PObj); + procedure CloseClick(Self_: KOL.PObj); + procedure OpenClick(Self_: KOL.PObj); + procedure SaveClick(Self_: KOL.PObj); + procedure CalcRects (Sender: PGRushControl; var Rects: TGRushRects); + procedure DoClose ( Sender: PObj; var Accept: Boolean ); + procedure ImageShowPaint ( Sender: PControl; DC: HDC ); + procedure SetControls; + end; + +procedure Register; + +var + ImageCollectionEditor: PImageCollectionEditor; + +procedure NewImageCollectionEditor( var Result: PImageCollectionEditor; Component: TKOLGRushImageCollection ); + +implementation + +procedure Register; +begin + RegisterComponentEditor( TKOLGRushImageCollection, TKOLGRushImageCollectionEditor ); +end; + +procedure NewImageCollectionEditor( var Result: PImageCollectionEditor; Component: TKOLGRushImageCollection ); +begin + New(Result, Create); + with Result^ do begin + Form := NewForm(nil, Component.Name + ': Edit').SetClientSize(440, 256).CenterOnParent; + KOL.Applet := Form; + Form.ExStyle := Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Form.Style := Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Form.CanResize := FALSE; + Form.OnClose := DoClose; + Form.Add2AutoFree(Result); + + ScrollBox := NewScrollBoxEx(Form, esLowered).SetPosition(8, 8).SetSize(320, 240).SetBorder(0); + + ImageShow := NewPanel(ScrollBox, esNone); + ImageShow.OnPaint := ImageShowPaint; + + ButtonOpen_Close := PGRushControl(NewGRushButton(Result.Form, '').SetSize(96, 24).SetPosition(336, 8)); + ButtonOpen_Close.OnRecalcRects := CalcRects; + + ButtonSave := PGRushControl(NewGRushButton(Result.Form, 'Save as').SetSize(96, 24).SetPosition(336, 40)); + ButtonSave.OnClick := Result.SaveClick; + ButtonSave.OnRecalcRects := CalcRects; + + ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetSize(96, 24).SetPosition(336, 192)); + ButtonOK.OnClick := Result.OKClick; + ButtonOK.OnRecalcRects := CalcRects; + ButtonOK.Focused := TRUE; + + ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetSize(96, 24).SetPosition(336, 224)); + ButtonCancel.OnClick := Result.CancelClick; + ButtonCancel.OnRecalcRects := CalcRects; + + OSD := NewOpenSaveDialog('chose file to open', ProjectSourcePath + , [OSFileMustExist, OSHideReadonly, OSPathMustExist, OSOverwritePrompt] ); + OSD.Filter := 'Jpeg files|*.jpg;*.jpeg|Png files|*.png|Gif files|*.gif|Bmp files|*.bmp|' + + 'All suported files|*.jpg;*.jpeg;*.png;*.gif;*.bmp|All files|*.*|'; + OSD.FilterIndex := 5; + OSD.WndOwner := Form.Handle; + + + + + Comp := Component; + Collection.fImageType := Component.ImageType; + if assigned(Component.DataStream) then begin + Collection.fDataStream := TMemoryStream.Create; + Collection.fDataStream.LoadFromStream(Component.DataStream); + end; + Bitmap := Component.LoadBitmap; + SetControls; + end; +end; + +procedure TKOLGRushImageCollectionEditor.Edit; +begin + if Component = nil then Exit; + if not(Component is TKOLGRushImageCollection) then Exit; + + ImageCollectionEditor := nil; + AppletTerminated := FALSE; + try + NewImageCollectionEditor(ImageCollectionEditor, Component as TKOLGRushImageCollection); + ImageCollectionEditor.ActiveWindow := GetActiveWindow; + ImageCollectionEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + + end; + (Component as TKOLGRushImageCollection).Change; +end; + +procedure TKOLGRushImageCollectionEditor.ExecuteVerb(Index: Integer); +begin + if Index = 0 then + Edit; +end; + +function TKOLGRushImageCollectionEditor.GetVerb(Index: Integer): string; +begin + if Index = 0 then + Result := 'Edit component'; +end; + +function TKOLGRushImageCollectionEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + + +procedure TImageCollectionEditor.SetControls; +begin + if Bitmap = nil then begin + try + Collection.fDataStream.Free; + finally + Collection.fDataStream := nil; + end; + Collection.fImageType := None; + ButtonOpen_Close.Caption := 'Open'; + ButtonOpen_Close.OnClick := OpenClick; + ButtonSave.Enabled := FALSE; + ImageShow.Visible := FALSE; + end else begin + ButtonOpen_Close.Caption := 'Free'; + ButtonOpen_Close.OnClick := CloseClick; + ButtonSave.Enabled := TRUE; + ImageShow.SetSize(Bitmap.Width, Bitmap.Height); + ImageShow.Visible := TRUE; + end; +end; + +procedure TImageCollectionEditor.OKClick(Self_: KOL.PObj); +begin + try + Comp.DataStream.Free; + finally + Comp.DataStream := nil; + end; + TKOLGRushImageCollectionImageType((@Comp.ImageType)^) := Collection.fImageType; + if Comp.ImageType <> None then begin + Comp.DataStream := TMemoryStream.Create; + Comp.DataStream.LoadFromStream(Collection.fDataStream); + Comp.DataStream.Position := 0; + end; + Form.Close; +end; + +procedure TImageCollectionEditor.CancelClick(Self_: KOL.PObj); +begin + Form.Close; +end; + +procedure TImageCollectionEditor.OpenClick(Self_: KOL.PObj); +var KOLStream: KOL.PStream; +begin + OSD.OpenDialog := TRUE; + if OSD.Execute then begin + Collection.fDataStream := TMemoryStream.Create; + Collection.fDataStream.LoadFromFile(OSD.FileName); + + KOLStream := NewExMemoryStream(Collection.fDataStream.Memory, Collection.fDataStream.Size); + try + tinyLoadPNG(Bitmap, KOLStream); + except + ShowMessage('Произошла ошибка во время попытки декадировать файл как *.png' + + '. Пожалуста сообщите об этом автору (homm86@mail.ru) и прекрепите' + + ' проблемный файл если его размер менее мегабайта.'); + try + Bitmap.Free; + finally + Bitmap := nil; + end; + end; + KOLStream.Free; + if Bitmap <> nil then begin + Collection.fImageType := PNG; + end else begin // maybe JPG? + tinyLoadJPGGIFBMPStream(Bitmap, Collection.fDataStream); + if Bitmap <> nil then begin + Collection.fImageType := BMP_GIF_JPG; + end else begin // not suported + Collection.fImageType := None; + ShowMessage ('This file type not suported.'); + try + Collection.fDataStream.Free; + finally + Collection.fDataStream := nil; + end; + try + Bitmap.Free; + finally + Bitmap := nil; + end; + end; + end; + SetControls; + end; +end; + +procedure TImageCollectionEditor.CloseClick(Self_: KOL.PObj); +begin + ImageShow.Visible := FALSE; + ButtonOpen_Close.OnClick := OpenClick; + ButtonOpen_Close.Caption := 'Open'; + ButtonSave.Enabled := FALSE; + Collection.fImageType := None; + try + Collection.fDataStream.Free; + finally + Collection.fDataStream := nil; + end; + try + Bitmap.Free; + finally + Bitmap := nil; + end; +end; + +procedure TImageCollectionEditor.SaveClick(Self_: KOL.PObj); +begin + try + OSD.OpenDialog := FALSE; + if OSD.Execute then begin + Collection.fDataStream.SaveToFile(OSD.FileName); + end; + except + ShowMessage('Не удается сохранить рисунок.'); + end; +end; + +procedure TImageCollectionEditor.DoClose ( Sender: PObj; var Accept: Boolean ); +begin + Accept := TRUE; + try + Collection.fDataStream.Free; + finally + Collection.fDataStream := nil; + end; + try + Bitmap.Free; + finally + Bitmap := nil; + end; + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TImageCollectionEditor.CalcRects (Sender: PGRushControl; var Rects: TGRushRects); +begin + InflateRect(Rects.AlphaRect, -4, -3); +end; + +procedure TImageCollectionEditor.ImageShowPaint ( Sender: PControl; DC: HDC ); +begin + if Bitmap <> nil then begin + BitBlt(DC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY); + end; +end; + +end. diff --git a/Addons/MCKGRushPanelEditor.pas b/Addons/MCKGRushPanelEditor.pas new file mode 100644 index 0000000..e120f25 --- /dev/null +++ b/Addons/MCKGRushPanelEditor.pas @@ -0,0 +1,2147 @@ +unit MCKGRushPanelEditor; + +// file: MCKGRushPanelEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, + {$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; + {$ELSE} + DsgnIntf; + {$ENDIF} + +type + TPanelStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + +{$I MCKfakeClasses.inc} + PPanelEditor = ^TPanelEditor; + TPanelEditor = object(TObj) + Form: PControl; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + Control: TKOLGRushPanel; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TPanelStylesProp; + Styles: TKOLGRushPanelStyles; + Component: MCKGRushControls.TKOLGRushPanel; + //GlyphBitmap: PBitmap; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + private + public + end; + +procedure Register; + +var PanelEditor: PPanelEditor; + +procedure NewPanelEditor(var Result: PPanelEditor; Prop: TPanelStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushPanelStyles), nil, '', TPanelStylesProp); +end; + +procedure NewPanelEditor(var Result: PPanelEditor; Prop: TPanelStylesProp); +begin + + New(Result, Create); + Result.Form := NewForm(nil, 'PanelEditor').SetPosition(193, 124).SetClientSize(520, 523); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.CD1.OwnerWindow := Result.Form.Handle; + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 464).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 464).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(400, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(272, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 208).SetSize(249, 305)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 248).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 248).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 224).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 248).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 248).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 272).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 176).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 200).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 200).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 80).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 104).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 104).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 128).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 152).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 152).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 248).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 200).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 200).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 248).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 248).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 272).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 248).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 272).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 102).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 102).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 150).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 150).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.Dis_ColorText := 8421504; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.Down_ShadowOffset := 1; + Result.AntiAliasing.Dis_ShadowOffset := 1; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.Down_ShadowOffset := 1; + Result.CropTopFirst.Dis_ShadowOffset := 1; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.Dis_ColorText := 8421504; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.Down_ShadowOffset := 1; + Result.DrawGlyph.Dis_ShadowOffset := 1; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.Dis_ColorText := 8421504; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.Down_ShadowOffset := 1; + Result.DrawText.Dis_ShadowOffset := 1; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.Down_ShadowOffset := 1; + Result.GlyphAttached.Dis_ShadowOffset := 1; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(128, 8).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.Dis_ColorText := 8421504; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.Down_ShadowOffset := 1; + Result.WordWrap.Dis_ShadowOffset := 1; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 8).SetSize(249, 193)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 168).SetSize(233, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Caption.Text := 'Panel control'; + Result.Control := PGRushControl(NewGRushPanel(Result.GRushPanel3).SetPosition(8, 24).SetSize(233, 113)); + Result.Control.Caption := 'PanelControl'; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 144).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 144).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushPanelStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushPanel); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushImageCollection1.Free; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); + +end; + +procedure TPanelEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TPanelEditor.KOLForm1FormCreate(Sender: PObj); +begin + + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + Antialiasing.Checked := Control.All_AntiAliasing; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); +end; + +procedure TPanelEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TPanelEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TPanelEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TPanelEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TPanelEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TPanelEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TPanelEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TPanelEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TPanelEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TPanelEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TPanelEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TPanelEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TPanelEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TPanelEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TPanelEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TPanelEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TPanelEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TPanelEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 1; + Control.All_TextHAlign := haCenter; + TextVert.CurIndex := 0; + Control.All_TextVAlign := vaTop; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '4'; + T.Text := '4'; + R.Text := '-4'; + B.Text := '-4'; + Control.All_ContentOffsets := MakeRect(4, 4, -4, -4); + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TPanelEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := 4; + Control.Def_BorderRoundHeight := 4; + BorderWi.Text := '4'; + BorderHe.Text := '4'; + end; + 2: + begin + Control.Dis_BorderRoundWidth := 5; + Control.Dis_BorderRoundHeight := 5; + BorderWi.Text := '5'; + BorderHe.Text := '5'; + end; + 0: + begin + Control.All_BorderRoundWidth := 4; + Control.All_BorderRoundHeight := 4; + Control.Down_BorderRoundWidth := 8; + Control.Dis_BorderRoundWidth := 5; + Control.Dis_BorderRoundHeight := 5; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '2'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Over_ShadowOffset := 1; + Control.Down_ShadowOffset := -1; + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 2: + begin + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 0: + begin + Control.Def_BorderWidth := 1; + Control.Over_BorderWidth := 1; + Control.Down_BorderWidth := 2; + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := gsVertical; + GradStyles.CurIndex := 1; + end; + 2: + begin + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 0: + begin + Control.Def_GradientStyle := gsVertical; + Control.Over_GradientStyle := gsDoubleVert; + Control.Down_GradientStyle := gsDoubleHorz; + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 2: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := clWhite; + Control.Over_ColorFrom := $00E1CEBF; + Control.Down_ColorFrom := $00F0FBFF; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $00D1BEAF; + Col3.Color := $00D1BEAF; + end; + 2: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $00D1BEAF; + Control.Over_ColorTo := clWhite; + Control.Down_ColorTo := $00B6BFC6; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 2: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := $00A4A0A0; + Control.Over_BorderColor := $00A4A0A0; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TPanelEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TPanelEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := TRUE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + KOLForm1FormCreate(PanelEditor); + Control.Invalidate; +end; + +procedure TPanelEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TPanelEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := 0;//Styles.SplitterDotsCount; + Data.fCheckMetric := 0;//Styles.CheckMetric; + Data.fColorCheck := 0;//Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := FALSE;//Styles.DrawFocusRect; + Data.fDrawProgress := FALSE;//Styles.DrawProgress; + Data.fDrawProgressRect := FALSE;//Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := FALSE;//Styles.ProgressVertical; + Data.fUpdateSpeed := usImmediately;//Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(PanelEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TPanelEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.Spacing := Data.fSpacing; + + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TPanelEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TPanelEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TPanelEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TPanelEditor.WordWrapClick(Sender: PObj); +begin +end; + + + + + +function TPanelStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TPanelStylesProp.Edit; +var Styles: TKOLGRushPanelStyles; +begin + Styles := TKOLGRushPanelStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushPanelStyles) then exit; + + PanelEditor := nil; + AppletTerminated := FALSE; + try + NewPanelEditor(PanelEditor, Self); + PanelEditor.ActiveWindow := GetActiveWindow; + PanelEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + +end. + diff --git a/Addons/MCKGRushProgressBarEditor.pas b/Addons/MCKGRushProgressBarEditor.pas new file mode 100644 index 0000000..b35b46e --- /dev/null +++ b/Addons/MCKGRushProgressBarEditor.pas @@ -0,0 +1,2290 @@ +unit MCKGRushProgressBarEditor; + +// file: MCKGRushProgressBarEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, + {$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; + {$ELSE} + DsgnIntf; + {$ENDIF} + +type + TProgressBarStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + {$I MCKfakeClasses.inc} + PProgressBarEditor = ^TProgressBarEditor; + TProgressBarEditor = object(TObj) + Form: PControl; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + Control: TKOLGRushProgressBar; + DrawProgress: TKOLGRushCheckBox; + DrawProgressRect: TKOLGRushCheckBox; + Horizontal: TKOLGRushRadioBox; + Vertical: TKOLGRushRadioBox; + MaxProgress: TKOLEditBox; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TProgressBarStylesProp; + Styles: TKOLGRushProgressBarStyles; + Component: MCKGRushControls.TKOLGRushProgressBar; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + procedure ControlMouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure ControlMouseUp(Sender: PControl; var Mouse: TMouseEventData); + procedure ControlMouseMove(Sender: PControl; + var Mouse: TMouseEventData); + procedure VerticalClick(Sender: PObj); + procedure DrawProgressClick(Sender: PObj); + procedure DrawProgressRectClick(Sender: PObj); + procedure MaxProgressChange(Sender: PObj); + private + public + end; + +var ProgressBarEditor: PProgressBarEditor; + +procedure Register; + +procedure NewProgressBarEditor(var Result: PProgressBarEditor; Prop: TProgressBarStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushProgressBarStyles), nil, '', TProgressBarStylesProp); +end; + +procedure NewProgressBarEditor(var Result: PProgressBarEditor; Prop: TProgressBarStylesProp); +begin + + New(Result, Create); + Result.Form := NewForm(nil, 'ProgressBarEditor').SetPosition(193, 124).SetClientSize(520, 565); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 512).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 512).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(400, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(272, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 208).SetSize(249, 353)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 296).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 296).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 272).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 296).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 296).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 320).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 224).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 248).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 248).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 128).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 152).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 152).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 176).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 200).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 200).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 296).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 248).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 248).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 296).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 296).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 320).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 296).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 272).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 320).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 150).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 150).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 198).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 198).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.Horizontal := PGRushControl(NewGRushRadioBox(Result.GRushPanel1, 'Horizontal').SetPosition(8, 104).SetSize(113, 17)); + Result.Horizontal.All_ColorOuter := 15259342; + Result.Horizontal.Dis_ColorText := 8421504; + Result.Horizontal.All_ColorShadow := 12632256; + Result.Horizontal.Over_BorderColor := 8421504; + Result.Horizontal.Down_BorderWidth := 1; + Result.Horizontal.Down_ShadowOffset := 1; + Result.Horizontal.Dis_ShadowOffset := 1; + Result.Vertical := PGRushControl(NewGRushRadioBox(Result.GRushPanel1, 'Vertical').SetPosition(128, 104).SetSize(113, 17)); + Result.Vertical.All_ColorOuter := 15259342; + Result.Vertical.Dis_ColorText := 8421504; + Result.Vertical.All_ColorShadow := 12632256; + Result.Vertical.Over_BorderColor := 8421504; + Result.Vertical.Down_BorderWidth := 1; + Result.Vertical.Down_ShadowOffset := 1; + Result.Vertical.Dis_ShadowOffset := 1; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.Dis_ColorText := 8421504; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.Down_ShadowOffset := 1; + Result.AntiAliasing.Dis_ShadowOffset := 1; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.Down_ShadowOffset := 1; + Result.CropTopFirst.Dis_ShadowOffset := 1; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.Dis_ColorText := 8421504; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.Down_ShadowOffset := 1; + Result.DrawGlyph.Dis_ShadowOffset := 1; + Result.DrawProgress := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw progress').SetPosition(8, 80).SetSize(113, 17)); + Result.DrawProgress.Down_ColorFrom := 14798527; + Result.DrawProgress.Down_ColorTo := 16777215; + Result.DrawProgress.All_ColorOuter := 15259342; + Result.DrawProgress.Dis_ColorText := 8421504; + Result.DrawProgress.All_ColorShadow := 12632256; + Result.DrawProgress.Over_BorderColor := 8421504; + Result.DrawProgress.Down_BorderWidth := 1; + Result.DrawProgress.Down_ShadowOffset := 1; + Result.DrawProgress.Dis_ShadowOffset := 1; + Result.DrawProgressRect := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Progress rect').SetPosition(128, 80).SetSize(113, 17)); + Result.DrawProgressRect.Down_ColorFrom := 14798527; + Result.DrawProgressRect.Down_ColorTo := 16777215; + Result.DrawProgressRect.All_ColorOuter := 15259342; + Result.DrawProgressRect.Dis_ColorText := 8421504; + Result.DrawProgressRect.All_ColorShadow := 12632256; + Result.DrawProgressRect.Over_BorderColor := 8421504; + Result.DrawProgressRect.Down_BorderWidth := 1; + Result.DrawProgressRect.Down_ShadowOffset := 1; + Result.DrawProgressRect.Dis_ShadowOffset := 1; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.Dis_ColorText := 8421504; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.Down_ShadowOffset := 1; + Result.DrawText.Dis_ShadowOffset := 1; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.Down_ShadowOffset := 1; + Result.GlyphAttached.Dis_ShadowOffset := 1; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(128, 8).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.Dis_ColorText := 8421504; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.Down_ShadowOffset := 1; + Result.WordWrap.Dis_ShadowOffset := 1; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 8).SetSize(249, 193)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 168).SetSize(113, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Caption.Text := 'Panel control'; + Result.MaxProgress := NewEditBox(Result.GRushPanel3, []).SetPosition(128, 168).SetSize(113, 17); + Result.MaxProgress.Ctl3D := False; + Result.MaxProgress.Font.FontStyle := []; + Result.MaxProgress.Text := '100'; + Result.Control := PGRushControl(NewGRushProgressBar(Result.GRushPanel3).SetPosition(8, 24).SetSize(233, 113)); + Result.Control.Progress := 30; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 144).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 144).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushProgressBarStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushProgressBar); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.MaxProgress := Component.MaxProgress; + Control.Progress := Component.Progress; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.MaxProgress.Color := clWindow; + Result.MaxProgress.OnChange := Result.MaxProgressChange; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.Control.OnMouseDown := Result.ControlMouseDown; + Result.Control.OnMouseMove := Result.ControlMouseMove; + Result.Control.OnMouseUp := Result.ControlMouseUp; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.Horizontal.OnClick := Result.VerticalClick; + Result.Vertical.OnClick := Result.VerticalClick; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawProgress.OnClick := Result.DrawProgressClick; + Result.DrawProgress.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawProgressRect.OnClick := Result.DrawProgressRectClick; + Result.DrawProgressRect.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushImageCollection1.Free; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); +end; + +procedure TProgressBarEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TProgressBarEditor.KOLForm1FormCreate(Sender: PObj); +begin + + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + if Control.All_ProgressVertical then + Vertical.Checked := TRUE + else + Horizontal.Checked := TRUE; + Antialiasing.Checked := Control.All_AntiAliasing; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + DrawProgress.Checked := Control.All_DrawProgress; + DrawProgressRect.Checked := Control.All_DrawProgressRect; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); +end; + +procedure TProgressBarEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TProgressBarEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TProgressBarEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TProgressBarEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TProgressBarEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TProgressBarEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TProgressBarEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TProgressBarEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TProgressBarEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TProgressBarEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TProgressBarEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TProgressBarEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 1; + Control.All_TextHAlign := haCenter; + TextVert.CurIndex := 1; + Control.All_TextVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '0'; + T.Text := '0'; + R.Text := '0'; + B.Text := '0'; + Control.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TProgressBarEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + if Control.All_ProgressVertical then begin + Control.Def_BorderRoundWidth := 25; + Control.Def_BorderRoundHeight := 4; + BorderWi.Text := '25'; + BorderHe.Text := '4'; + end else begin + Control.Def_BorderRoundWidth := 4; + Control.Def_BorderRoundHeight := 25; + BorderWi.Text := '4'; + BorderHe.Text := '25'; + end; + end; + 2: + begin + if Control.All_ProgressVertical then begin + Control.Dis_BorderRoundWidth := 25; + Control.Dis_BorderRoundHeight := 4; + BorderWi.Text := '25'; + BorderHe.Text := '4'; + end else begin + Control.Dis_BorderRoundWidth := 4; + Control.Dis_BorderRoundHeight := 25; + BorderWi.Text := '4'; + BorderHe.Text := '25'; + end; + end; + 0: + begin + if Control.All_ProgressVertical then begin + Control.All_BorderRoundWidth := 25; + Control.All_BorderRoundHeight := 4; + end else begin + Control.All_BorderRoundWidth := 4; + Control.All_BorderRoundHeight := 25; + end; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Dis_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Dis_ShadowOffset := 1; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 2: + begin + Control.Dis_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 0: + begin + Control.Def_BorderWidth := 1; + Control.Dis_BorderWidth := 1; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + if Control.All_ProgressVertical then begin + Control.Def_GradientStyle := gsDoubleHorz; + GradStyles.CurIndex := 4; + end else begin + Control.Def_GradientStyle := gsDoubleVert; + GradStyles.CurIndex := 3; + end; + end; + 2: + begin + if Control.All_ProgressVertical then begin + Control.Dis_GradientStyle := gsDoubleHorz; + GradStyles.CurIndex := 4; + end else begin + Control.Def_GradientStyle := gsDoubleVert; + GradStyles.CurIndex := 3; + end; + end; + 0: + begin + if Control.All_ProgressVertical then begin + Control.Def_GradientStyle := gsDoubleHorz; + Control.Dis_GradientStyle := gsDoubleHorz; + end else begin + Control.Def_GradientStyle := gsDoubleVert; + Control.Dis_GradientStyle := gsDoubleVert; + end; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := $E0D2C9; + Col2.Color := $E0D2C9; + end; + 2: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := $E0D2C9; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $B6977E; + Col3.Color := $B6977E; + end; + 2: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $B6977E; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 2: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := $00A4A0A0; + Control.Over_BorderColor := $00A4A0A0; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TProgressBarEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TProgressBarEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + Control.All_ProgressVertical := FALSE; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := TRUE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + KOLForm1FormCreate(ProgressBarEditor); + Control.Progress := Control.Progress; + Control.Invalidate; +end; + +procedure TProgressBarEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TProgressBarEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := 0;//Styles.SplitterDotsCount; + Data.fCheckMetric := 0;//Styles.CheckMetric; + Data.fColorCheck := 0;//Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := TRUE;//Styles.DrawFocusRect; + Data.fDrawProgress := Styles.DrawProgress; + Data.fDrawProgressRect := Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := Styles.ProgressVertical; + Data.fUpdateSpeed := usImmediately;//Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(ProgressBarEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TProgressBarEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.ProgressVertical := Data.fProgressVertical; + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.Spacing := Data.fSpacing; + Styles.DrawProgress := Data.fDrawProgress; + Styles.DrawProgressRect := Data.fDrawProgressRect; + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TProgressBarEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TProgressBarEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TProgressBarEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TProgressBarEditor.WordWrapClick(Sender: PObj); +begin +end; + +procedure TProgressBarEditor.ControlMouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + Sender.Tag := $FF; +end; + +procedure TProgressBarEditor.ControlMouseUp(Sender: PControl; + var Mouse: TMouseEventData); +begin + Sender.Tag := 0; +end; + +procedure TProgressBarEditor.ControlMouseMove(Sender: PControl; + var Mouse: TMouseEventData); +begin + if Sender.Tag = $FF then begin + if Control.All_ProgressVertical then + Control.Progress := ((Control.Height - Mouse.Y) * Control.MaxProgress) div (Control.Height - 2) + else + Control.Progress := (Mouse.X * Control.MaxProgress) div (Control.Width - 2); + end; +end; + +procedure TProgressBarEditor.VerticalClick(Sender: PObj); +begin + Control.All_ProgressVertical := Vertical.Checked; + KOLForm1FormCreate(@Self); + Control.Progress := Control.Progress; + Control.Invalidate; +end; + +procedure TProgressBarEditor.DrawProgressClick(Sender: PObj); +begin + Control.All_DrawProgress := DrawProgress.Checked; + Control.Invalidate; +end; + +procedure TProgressBarEditor.DrawProgressRectClick(Sender: PObj); +begin + Control.All_DrawProgressRect := DrawProgressRect.Checked; + Control.Invalidate; +end; + +procedure TProgressBarEditor.MaxProgressChange(Sender: PObj); +begin + Control.MaxProgress := str2int(MaxProgress.Text); + Control.Invalidate; +end; + + + + + +function TProgressBarStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TProgressBarStylesProp.Edit; +var Styles: TKOLGRushProgressBarStyles; +begin + Styles := TKOLGRushProgressBarStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushProgressBarStyles) then exit; + + ProgressBarEditor := nil; + AppletTerminated := FALSE; + try + NewProgressBarEditor(ProgressBarEditor, Self); + ProgressBarEditor.ActiveWindow := GetActiveWindow; + ProgressBarEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + +end. + diff --git a/Addons/MCKGRushRadioBoxEditor.pas b/Addons/MCKGRushRadioBoxEditor.pas new file mode 100644 index 0000000..4fc575c --- /dev/null +++ b/Addons/MCKGRushRadioBoxEditor.pas @@ -0,0 +1,2620 @@ +unit MCKGRushRadioBoxEditor; + +// file: MCKGRushRadioBoxEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, +{$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; +{$ELSE} + DsgnIntf; +{$ENDIF} + +type + TRadioBoxStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + +{$I MCKfakeClasses.inc} + PRadioBoxEditor = ^TRadioBoxEditor; + TRadioBoxEditor = object(TObj) + Form: PControl; + KOLProject1: TKOLProject; + KOLForm1: TKOLForm; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down3: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + DrawFocus: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label25: TKOLLabel; + UpdateSpeed: TKOLComboBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton19: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + Control: TKOLGRushCheckBox; + Label32: TKOLLabel; + ColorCheck: TKOLLabel; + GRushButton21: TKOLGRushButton; + Label33: TKOLLabel; + CheckMetric: TKOLEditBox; + GRushButton22: TKOLGRushButton; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TRadioBoxStylesProp; + Styles: TKOLGRushRadioBoxStyles; + Component: MCKGRushControls.TKOLGRushRadioBox; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down3Click(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure UpdateSpeedSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawFocusClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton19Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + procedure CheckMetricLeave(Sender: PObj); + procedure GRushButton22Click(Sender: PObj); + procedure ColorCheckClick(Sender: PObj); + procedure GRushButton21Click(Sender: PObj); + private + public + end; + +var RadioBoxEditor: PRadioBoxEditor; + +procedure Register; +procedure NewRadioBoxEditor(var Result: PRadioBoxEditor; Prop: TRadioBoxStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushRadioBoxStyles), nil, '', TRadioBoxStylesProp); +end; + +procedure NewRadioBoxEditor(var Result: PRadioBoxEditor; Prop: TRadioBoxStylesProp); +begin + + New(Result, Create); + Result.Form := NewForm(nil, 'RadioBoxEditor').SetPosition(221, 110).SetClientSize(520, 561); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 504).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 504).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(401, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(273, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Over state'; + Result.StatesList.Items[3] := 'Down state'; + Result.StatesList.Items[4] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 160).SetSize(249, 393)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.ColorCheck := NewLabel(Result.GRushPanel1, '').SetPosition(128, 104).SetSize(49, 17); + Result.ColorCheck.Color := clSilver; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 320).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 320).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 296).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 320).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 320).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 344).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 248).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label25 := NewLabel(Result.GRushPanel1, 'Update speed:').SetPosition(8, 368).SetSize(97, 17); + Result.Label25.TextAlign := taRight; + Result.Label25.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 152).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 176).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 176).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 200).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 224).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 224).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.Label32 := NewLabel(Result.GRushPanel1, 'Check color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label32.TextAlign := taRight; + Result.Label32.Color := $E8D6CE; + Result.Label33 := NewLabel(Result.GRushPanel1, 'Size of check:').SetPosition(8, 128).SetSize(97, 17); + Result.Label33.TextAlign := taRight; + Result.Label33.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 320).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.CheckMetric := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 128).SetSize(81, 17); + Result.CheckMetric.Ctl3D := False; + Result.CheckMetric.Font.FontHeight := 8; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 272).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 272).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 320).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 320).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 344).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 320).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 344).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton19 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 368).SetSize(41, 17)); + Result.GRushButton19.Font.FontHeight := 8; + Result.GRushButton19.All_BorderRoundWidth := 0; + Result.GRushButton19.All_BorderRoundHeight := 0; + Result.GRushButton19.Down_BorderWidth := 1; + Result.GRushButton19.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton21 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton21.Font.FontHeight := 8; + Result.GRushButton21.All_BorderRoundWidth := 0; + Result.GRushButton21.All_BorderRoundHeight := 0; + Result.GRushButton21.Down_BorderWidth := 1; + Result.GRushButton21.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton22 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton22.Font.FontHeight := 8; + Result.GRushButton22.All_BorderRoundWidth := 0; + Result.GRushButton22.All_BorderRoundHeight := 0; + Result.GRushButton22.Down_BorderWidth := 1; + Result.GRushButton22.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 174).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 174).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 222).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 222).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.UpdateSpeed := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 366).SetSize(81, 21); + Result.UpdateSpeed.Font.FontHeight := 8; + Result.UpdateSpeed.Color := clWindow; + Result.UpdateSpeed.Items[0] := 'Immediately'; + Result.UpdateSpeed.Items[1] := 'Very fast'; + Result.UpdateSpeed.Items[2] := 'Fast'; + Result.UpdateSpeed.Items[3] := 'Normal'; + Result.UpdateSpeed.Items[4] := 'Slow'; + Result.UpdateSpeed.Items[5] := 'Very slow'; + Result.UpdateSpeed.CurIndex := 0; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.All_ShadowOffset := 0; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.All_ShadowOffset := 0; + Result.DrawFocus := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw focus').SetPosition(128, 8).SetSize(113, 17)); + Result.DrawFocus.Down_ColorFrom := 14798527; + Result.DrawFocus.Down_ColorTo := 16777215; + Result.DrawFocus.All_ColorOuter := 15259342; + Result.DrawFocus.All_ColorShadow := 12632256; + Result.DrawFocus.Over_BorderColor := 8421504; + Result.DrawFocus.Down_BorderWidth := 1; + Result.DrawFocus.All_ShadowOffset := 0; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.All_ShadowOffset := 0; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.All_ShadowOffset := 0; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.All_ShadowOffset := 0; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(8, 80).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.All_ShadowOffset := 0; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(7, 8).SetSize(249, 145)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 120).SetSize(233, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Caption.Text := 'Button control'; + Result.Control := PGRushControl(NewGRushRadioBox(Result.GRushPanel3, 'CheckBox1').SetPosition(8, 24).SetSize(233, 65)); + Result.Control.DoubleBuffered := True; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 96).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 96).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down3 := PGRushControl(NewGRushButton(Result.UpdateSpeed, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down3.All_BorderRoundWidth := 0; + Result.Down3.All_BorderRoundHeight := 0; + Result.Down3.Down_BorderWidth := 1; + Result.Down3.Dis_BorderWidth := 1; + Result.Down3.Def_ShadowOffset := 0; + Result.Down3.Over_ShadowOffset := 0; + Result.Down3.Down_ShadowOffset := 255; + Result.Down3.Dis_ShadowOffset := 0; + Result.Down3.Over_GlyphItemY := 1; + Result.Down3.Down_GlyphItemY := 2; + Result.Down3.Dis_GlyphItemY := 3; + Result.Down3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down3.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down3.All_GlyphWidth := 12; + Result.Down3.All_GlyphHeight := 12; + Result.Down3.All_GlyphHAlign := haCenter; + Result.Down3.All_Spacing := 0; + Result.Down3.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushRadioBoxStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushRadioBox); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.ColorCheck.OnClick := Result.ColorCheckClick; + Result.ColorCheck.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.CheckMetric.Color := clWindow; + Result.CheckMetric.OnEnter := Result.BorderWiEnter; + Result.CheckMetric.OnLeave := Result.CheckMetricLeave; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down3.OnClick := Result.Down3Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton19.OnClick := Result.GRushButton19Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushImageCollection1.Free; + Result.GRushButton21.OnClick := Result.GRushButton21Click; + Result.GRushButton22.OnClick := Result.GRushButton22Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.UpdateSpeed.OnSelChange := Result.UpdateSpeedSelChange; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawFocus.OnClick := Result.DrawFocusClick; + Result.DrawFocus.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); +end; + +procedure TRadioBoxEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TRadioBoxEditor.KOLForm1FormCreate(Sender: PObj); +begin + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + Antialiasing.Checked := Control.All_AntiAliasing; + DrawFocus.Checked := Control.All_DrawFocusRect; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); + UpdateSpeed.CurIndex := Integer(Control.All_UpdateSpeed); + CheckMetric.Caption := int2str(Control.All_CheckMetric); + ColorCheck.Color := Control.All_ColorCheck; +end; + +procedure TRadioBoxEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TRadioBoxEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Down3Click(Sender: PObj); +begin + UpdateSpeed.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TRadioBoxEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Over_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 3: + begin + Control.Down_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 4: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorOuter; + if CD1.Execute then + Control.Over_ColorOuter := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorOuter; + if CD1.Execute then + Control.Down_ColorOuter := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorFrom; + if CD1.Execute then + Control.Over_ColorFrom := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorFrom; + if CD1.Execute then + Control.Down_ColorFrom := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorTo; + if CD1.Execute then + Control.Over_ColorTo := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorTo; + if CD1.Execute then + Control.Down_ColorTo := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_BorderColor; + if CD1.Execute then + Control.Over_BorderColor := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_BorderColor; + if CD1.Execute then + Control.Down_BorderColor := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorText; + if CD1.Execute then + Control.Over_ColorText := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorText; + if CD1.Execute then + Control.Down_ColorText := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorShadow; + if CD1.Execute then + Control.Over_ColorShadow := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorShadow; + if CD1.Execute then + Control.Down_ColorShadow := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Over_ColorOuter; + Col2.Color := Control.Over_ColorFrom; + Col3.Color := Control.Over_ColorTo; + Col4.Color := Control.Over_BorderColor; + Col5.Color := Control.Over_ColorText; + Col6.Color := Control.Over_ColorShadow; + GradStyles.CurIndex := Integer(Control.Over_GradientStyle); + BorderWidth.Text := int2str(Control.Over_BorderWidth); + ShadowOffset.Text := int2str(Control.Over_ShadowOffset); + BorderWi.Text := int2str(Control.Over_BorderRoundWidth); + BorderHe.Text := int2str(Control.Over_BorderRoundHeight); + GlyphX.Text := int2str(Control.Over_GlyphItemX); + GlyphY.Text := int2str(Control.Over_GlyphItemY); + end; + 3: + begin + Col1.Color := Control.Down_ColorOuter; + Col2.Color := Control.Down_ColorFrom; + Col3.Color := Control.Down_ColorTo; + Col4.Color := Control.Down_BorderColor; + Col5.Color := Control.Down_ColorText; + Col6.Color := Control.Down_ColorShadow; + GradStyles.CurIndex := Integer(Control.Down_GradientStyle); + BorderWidth.Text := int2str(Control.Down_BorderWidth); + ShadowOffset.Text := int2str(Control.Down_ShadowOffset); + BorderWi.Text := int2str(Control.Down_BorderRoundWidth); + BorderHe.Text := int2str(Control.Down_BorderRoundHeight); + GlyphX.Text := int2str(Control.Down_GlyphItemX); + GlyphY.Text := int2str(Control.Down_GlyphItemY); + end; + 4: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TRadioBoxEditor.UpdateSpeedSelChange(Sender: PObj); +begin + Control.All_UpdateSpeed := TGRushSpeed(UpdateSpeed.CurIndex); +end; + +procedure TRadioBoxEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.DrawFocusClick(Sender: PObj); +begin + Control.All_DrawFocusRect := DrawFocus.Checked; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TRadioBoxEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TRadioBoxEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TRadioBoxEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TRadioBoxEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Over_BorderRoundWidth := Val; + end; + 3: + begin + Control.Down_BorderRoundWidth := Val; + end; + 4: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Over_BorderRoundHeight := Val; + end; + 3: + begin + Control.Down_BorderRoundHeight := Val; + end; + 4: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Over_GlyphItemX := Val; + end; + 3: + begin + Control.Down_GlyphItemX := Val; + end; + 4: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Over_GlyphItemY := Val; + end; + 3: + begin + Control.Down_GlyphItemY := Val; + end; + 4: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Over_ShadowOffset := Val; + end; + 3: + begin + Control.Down_ShadowOffset := Val; + end; + 4: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Over_BorderWidth := Val; + end; + 3: + begin + Control.Down_BorderWidth := Val; + end; + 4: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 0; + Control.All_TextHAlign := haLeft; + TextVert.CurIndex := 1; + Control.All_TextVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '19'; + T.Text := '1'; + R.Text := '-1'; + B.Text := '-1'; + Control.All_ContentOffsets := MakeRect(19, 1, -1, -1); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton19Click(Sender: PObj); +begin + UpdateSpeed.CurIndex := 2; + Control.All_UpdateSpeed := usFast; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Over_GlyphItemX := 0; + Control.Over_GlyphItemY := 0; + end; + 3: + begin + Control.Down_GlyphItemX := 0; + Control.Down_GlyphItemY := 0; + end; + 4: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TRadioBoxEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := 50; + Control.Def_BorderRoundHeight := 50; + BorderWi.Text := '50'; + BorderHe.Text := '50'; + end; + 2: + begin + Control.Over_BorderRoundWidth := 50; + Control.Over_BorderRoundHeight := 50; + BorderWi.Text := '50'; + BorderHe.Text := '50'; + end; + 3: + begin + Control.Down_BorderRoundWidth := 50; + Control.Down_BorderRoundHeight := 50; + BorderWi.Text := '50'; + BorderHe.Text := '50'; + end; + 4: + begin + Control.Dis_BorderRoundWidth := 50; + Control.Dis_BorderRoundHeight := 50; + BorderWi.Text := '50'; + BorderHe.Text := '50'; + end; + 0: + begin + Control.All_BorderRoundWidth := 50; + Control.All_BorderRoundHeight := 50; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Over_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 3: + begin + Control.Down_ShadowOffset := -1; + ShadowOffset.Text := '-1'; + end; + 4: + begin + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '2'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Over_ShadowOffset := 1; + Control.Down_ShadowOffset := -1; + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 2: + begin + Control.Over_BorderWidth := 1; + BorderWidth.Text := '1'; + end; + 3: + begin + Control.Down_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 4: + begin + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '2'; + end; + 0: + begin + Control.Def_BorderWidth := 1; + Control.Over_BorderWidth := 1; + Control.Down_BorderWidth := 2; + Control.Dis_BorderWidth := 2; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 2: + begin + Control.Over_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 3: + begin + Control.Down_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 4: + begin + Control.Dis_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 5; + end; + 0: + begin + Control.All_GradientStyle := gsFromTopLeft; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Over_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 3: + begin + Control.Down_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 4: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 2: + begin + Control.Over_ColorFrom := $00E1CEBF; + Col2.Color := $00E1CEBF; + end; + 3: + begin + Control.Down_ColorFrom := $00F0FBFF; + Col2.Color := $00F0FBFF; + end; + 4: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := clWhite; + Control.Over_ColorFrom := $00E1CEBF; + Control.Down_ColorFrom := $00F0FBFF; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $00D1BEAF; + Col3.Color := $00D1BEAF; + end; + 2: + begin + Control.Over_ColorTo := clWhite; + Col3.Color := clWhite; + end; + 3: + begin + Control.Down_ColorTo := $00B6BFC6; + Col3.Color := $00B6BFC6; + end; + 4: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $00D1BEAF; + Control.Over_ColorTo := clWhite; + Control.Down_ColorTo := $00B6BFC6; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := clGray; + Col4.Color := clGray; + end; + 2: + begin + Control.Over_BorderColor := $404040; + Col4.Color := $404040; + end; + 3: + begin + Control.Down_BorderColor := clGray; + Col4.Color := clGray; + end; + 4: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := clGray; + Control.Over_BorderColor := $404040; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Over_ColorText := clBlack; + Col5.Color := clBlack; + end; + 3: + begin + Control.Down_ColorText := clBlack; + Col5.Color := clBlack; + end; + 4: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Over_ColorShadow := clGray; + Col5.Color := clGray; + end; + 3: + begin + Control.Down_ColorShadow := clGray; + Col5.Color := clGray; + end; + 4: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TRadioBoxEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + GRushButton19Click(GRushButton19); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := TRUE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + KOLForm1FormCreate(RadioBoxEditor); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TRadioBoxEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSOver.ColorFrom := Styles.OverPaintState.ColorFrom; + Data.fPSOver.ColorTo := Styles.OverPaintState.ColorTo; + Data.fPSOver.ColorOuter := Styles.OverPaintState.ColorOuter; + Data.fPSOver.ColorText := Styles.OverPaintState.ColorText; + Data.fPSOver.ColorShadow := Styles.OverPaintState.ColorShadow; + Data.fPSOver.BorderColor := Styles.OverPaintState.BorderColor; + Data.fPSOver.BorderRoundWidth := Styles.OverPaintState.BorderRoundWidth; + Data.fPSOver.BorderRoundHeight := Styles.OverPaintState.BorderRoundHeight; + Data.fPSOver.BorderWidth := Styles.OverPaintState.BorderWidth; + Data.fPSOver.GradientStyle := Styles.OverPaintState.GradientStyle; + Data.fPSOver.ShadowOffset := Styles.OverPaintState.ShadowOffset; + Data.fPSOver.GlyphItemX := Styles.OverPaintState.GlyphItemX; + Data.fPSOver.GlyphItemY := Styles.OverPaintState.GlyphItemY; + + Data.fPSDown.ColorFrom := Styles.DownPaintState.ColorFrom; + Data.fPSDown.ColorTo := Styles.DownPaintState.ColorTo; + Data.fPSDown.ColorOuter := Styles.DownPaintState.ColorOuter; + Data.fPSDown.ColorText := Styles.DownPaintState.ColorText; + Data.fPSDown.ColorShadow := Styles.DownPaintState.ColorShadow; + Data.fPSDown.BorderColor := Styles.DownPaintState.BorderColor; + Data.fPSDown.BorderRoundWidth := Styles.DownPaintState.BorderRoundWidth; + Data.fPSDown.BorderRoundHeight := Styles.DownPaintState.BorderRoundHeight; + Data.fPSDown.BorderWidth := Styles.DownPaintState.BorderWidth; + Data.fPSDown.GradientStyle := Styles.DownPaintState.GradientStyle; + Data.fPSDown.ShadowOffset := Styles.DownPaintState.ShadowOffset; + Data.fPSDown.GlyphItemX := Styles.DownPaintState.GlyphItemX; + Data.fPSDown.GlyphItemY := Styles.DownPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := 0;//Styles.SplitterDotsCount; + Data.fCheckMetric := Styles.CheckMetric; + Data.fColorCheck := Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := Styles.DrawFocusRect; + Data.fDrawProgress := FALSE;//Styles.DrawProgress; + Data.fDrawProgressRect := FALSE;//Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := FALSE;//Styles.ProgressVertical; + Data.fUpdateSpeed := Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(RadioBoxEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.ColorCheck := Data.fColorCheck; + Styles.CheckMetric := Data.fCheckMetric; + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.OverPaintState.ColorFrom := Data.fPSOver.ColorFrom; + Styles.OverPaintState.ColorTo := Data.fPSOver.ColorTo; + Styles.OverPaintState.ColorOuter := Data.fPSOver.ColorOuter; + Styles.OverPaintState.ColorText := Data.fPSOver.ColorText; + Styles.OverPaintState.ColorShadow := Data.fPSOver.ColorShadow; + Styles.OverPaintState.BorderColor := Data.fPSOver.BorderColor; + Styles.OverPaintState.BorderRoundWidth := Data.fPSOver.BorderRoundWidth; + Styles.OverPaintState.BorderRoundHeight := Data.fPSOver.BorderRoundHeight; + Styles.OverPaintState.BorderWidth := Data.fPSOver.BorderWidth; + Styles.OverPaintState.GradientStyle := Data.fPSOver.GradientStyle; + Styles.OverPaintState.ShadowOffset := Data.fPSOver.ShadowOffset; + Styles.OverPaintState.GlyphItemX := Data.fPSOver.GlyphItemX; + Styles.OverPaintState.GlyphItemY := Data.fPSOver.GlyphItemY; + + Styles.DownPaintState.ColorFrom := Data.fPSDown.ColorFrom; + Styles.DownPaintState.ColorTo := Data.fPSDown.ColorTo; + Styles.DownPaintState.ColorOuter := Data.fPSDown.ColorOuter; + Styles.DownPaintState.ColorText := Data.fPSDown.ColorText; + Styles.DownPaintState.ColorShadow := Data.fPSDown.ColorShadow; + Styles.DownPaintState.BorderColor := Data.fPSDown.BorderColor; + Styles.DownPaintState.BorderRoundWidth := Data.fPSDown.BorderRoundWidth; + Styles.DownPaintState.BorderRoundHeight := Data.fPSDown.BorderRoundHeight; + Styles.DownPaintState.BorderWidth := Data.fPSDown.BorderWidth; + Styles.DownPaintState.GradientStyle := Data.fPSDown.GradientStyle; + Styles.DownPaintState.ShadowOffset := Data.fPSDown.ShadowOffset; + Styles.DownPaintState.GlyphItemX := Data.fPSDown.GlyphItemX; + Styles.DownPaintState.GlyphItemY := Data.fPSDown.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.DrawFocusRect := Data.fDrawFocusRect; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.UpdateSpeed := Data.fUpdateSpeed; + Styles.Spacing := Data.fSpacing; + + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TRadioBoxEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TRadioBoxEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TRadioBoxEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TRadioBoxEditor.WordWrapClick(Sender: PObj); +begin +end; + +procedure TRadioBoxEditor.CheckMetricLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_CheckMetric := Val; + L.Text := int2str(Control.All_ContentOffsets.Left); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton22Click(Sender: PObj); +begin + Control.All_CheckMetric := 13; + CheckMetric.Caption := '13'; + L.Text := int2str(Control.All_ContentOffsets.Left); + Control.Invalidate; +end; + +procedure TRadioBoxEditor.ColorCheckClick(Sender: PObj); +begin + CD1.Color := Control.All_ColorCheck; + if CD1.Execute then + Control.All_ColorCheck := CD1.Color; + Control.Invalidate; +end; + +procedure TRadioBoxEditor.GRushButton21Click(Sender: PObj); +begin + ColorCheck.Color := $F3706C; + Control.All_ColorCheck := $F3706C; +end; + + + +function TRadioBoxStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TRadioBoxStylesProp.Edit; +var Styles: TKOLGRushRadioBoxStyles; +begin + Styles := TKOLGRushRadioBoxStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushRadioBoxStyles) then exit; + + RadioBoxEditor := nil; + AppletTerminated := FALSE; + try + NewRadioBoxEditor(RadioBoxEditor, Self); + RadioBoxEditor.ActiveWindow := GetActiveWindow; + RadioBoxEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + +end. + diff --git a/Addons/MCKGRushSplitterEditor.pas b/Addons/MCKGRushSplitterEditor.pas new file mode 100644 index 0000000..c843833 --- /dev/null +++ b/Addons/MCKGRushSplitterEditor.pas @@ -0,0 +1,2605 @@ +unit MCKGRushSplitterEditor; + +// file: MCKGRushSplitterEditor.pas +// file version: 0.35 +// last modified: 06.02.06 +// package: GRushControls +// author: Karpinskyj Alexandr aka homm +// mailto: homm86@mail.ru +// My humble Web-Page: http://www.homm86.narod.ru + +{$I KOLDEF.INC} + +interface + +uses Windows, + Messages, + ShellAPI, + MCKGRushControls, + tinyJPGGIFBMP, + tinyPNG, + mirror, + Classes, + Controls, + mckObjs, + Graphics, + mckCtrls, + Forms, + KOL, + KOLGRushControls, + {$IFDEF _D6orHigher} + DesignEditors, + DesignIntf; + {$ELSE} + DsgnIntf; + {$ENDIF} + +type + TSplitterStylesProp = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + {$I MCKfakeClasses.inc} + PSplitterEditor = ^TSplitterEditor; + TSplitterEditor = object(TObj) + Form: PControl; + GRushImageCollection1: TKOLGRushImageCollection; + CD1: TKOLColorDialog; + ButtonOK: TKOLGRushButton; + ButtonCancel: TKOLGRushButton; + LabelState: TKOLLabel; + StatesList: TKOLComboBox; + Down1: TKOLGRushButton; + Down2: TKOLGRushButton; + Down3: TKOLGRushButton; + Down4: TKOLGRushButton; + Down5: TKOLGRushButton; + Down6: TKOLGRushButton; + Down7: TKOLGRushButton; + GRushPanel1: TKOLGRushPanel; + CropTopFirst: TKOLGRushCheckBox; + AntiAliasing: TKOLGRushCheckBox; + DrawGlyph: TKOLGRushCheckBox; + DrawText: TKOLGRushCheckBox; + GlyphAttached: TKOLGRushCheckBox; + Label22: TKOLLabel; + GlyphWidth: TKOLEditBox; + Label23: TKOLLabel; + Label24: TKOLLabel; + GlyphHeight: TKOLEditBox; + Label25: TKOLLabel; + UpdateSpeed: TKOLComboBox; + Label26: TKOLLabel; + Label27: TKOLLabel; + Label28: TKOLLabel; + GlyphHorz: TKOLComboBox; + GlyphVert: TKOLComboBox; + Label29: TKOLLabel; + Label30: TKOLLabel; + TextHorz: TKOLComboBox; + Label31: TKOLLabel; + TextVert: TKOLComboBox; + GRushButton11: TKOLGRushButton; + GRushButton12: TKOLGRushButton; + GRushButton13: TKOLGRushButton; + Label16: TKOLLabel; + L: TKOLEditBox; + Label18: TKOLLabel; + GRushButton16: TKOLGRushButton; + Label17: TKOLLabel; + T: TKOLEditBox; + Label19: TKOLLabel; + R: TKOLEditBox; + Label20: TKOLLabel; + B: TKOLEditBox; + Label21: TKOLLabel; + Spacing: TKOLEditBox; + GRushButton17: TKOLGRushButton; + GRushPanel2: TKOLGRushPanel; + Label1: TKOLLabel; + Label2: TKOLLabel; + Label3: TKOLLabel; + Label4: TKOLLabel; + Label5: TKOLLabel; + Label6: TKOLLabel; + Label7: TKOLLabel; + GradStyles: TKOLComboBox; + Label8: TKOLLabel; + Label9: TKOLLabel; + Label11: TKOLLabel; + Label12: TKOLLabel; + Label13: TKOLLabel; + Label14: TKOLLabel; + BorderWi: TKOLEditBox; + BorderHe: TKOLEditBox; + Label10: TKOLLabel; + GlyphX: TKOLEditBox; + Label15: TKOLLabel; + GlyphY: TKOLEditBox; + Col1: TKOLLabel; + Col2: TKOLLabel; + Col3: TKOLLabel; + Col4: TKOLLabel; + Col5: TKOLLabel; + Col6: TKOLLabel; + BorderWidth: TKOLEditBox; + ShadowOffset: TKOLEditBox; + GRushButton1: TKOLGRushButton; + GRushButton2: TKOLGRushButton; + GRushButton3: TKOLGRushButton; + GRushButton4: TKOLGRushButton; + GRushButton5: TKOLGRushButton; + GRushButton6: TKOLGRushButton; + GRushButton7: TKOLGRushButton; + GRushButton8: TKOLGRushButton; + GRushButton9: TKOLGRushButton; + GRushButton10: TKOLGRushButton; + GRushButton14: TKOLGRushButton; + GRushPanel3: TKOLGRushPanel; + Control: TKOLGRushButton; + CheckEnabled: TKOLGRushCheckBox; + CheckTransparent: TKOLGRushCheckBox; + Caption: TKOLEditBox; + GRushButton18: TKOLGRushButton; + GRushButton19: TKOLGRushButton; + GRushButton20: TKOLGRushButton; + GRushButton15: TKOLGRushButton; + WordWrap: TKOLGRushCheckBox; + Label32: TKOLLabel; + DotsCount: TKOLEditBox; + GRushButton21: TKOLGRushButton; + /////////////////// + ActiveWindow: HWnd; + WindowList: Pointer; + Prop: TSplitterStylesProp; + Styles: TKOLGRushSplitterStyles; + Component: MCKGRushControls.TKOLGRushSplitter; + procedure KOLForm1BeforeCreateWindow(Sender: PObj); + procedure KOLForm1FormCreate(Sender: PObj); + procedure Down1Click(Sender: PObj); + procedure Down2Click(Sender: PObj); + procedure CheckEnabledClick(Sender: PObj); + procedure CheckTransparentClick(Sender: PObj); + procedure Down3Click(Sender: PObj); + procedure Down4Click(Sender: PObj); + procedure Down5Click(Sender: PObj); + procedure Down6Click(Sender: PObj); + procedure Down7Click(Sender: PObj); + procedure GradStylesSelChange(Sender: PObj); + procedure Col1Click(Sender: PObj); + procedure Col2Click(Sender: PObj); + procedure Col3Click(Sender: PObj); + procedure Col4Click(Sender: PObj); + procedure Col5Click(Sender: PObj); + procedure Col6Click(Sender: PObj); + procedure StatesListSelChange(Sender: PObj); + procedure UpdateSpeedSelChange(Sender: PObj); + procedure AntiAliasingClick(Sender: PObj); + procedure DrawGlyphClick(Sender: PObj); + procedure DrawTextClick(Sender: PObj); + procedure CaptionChange(Sender: PObj); + procedure GlyphHorzSelChange(Sender: PObj); + procedure GlyphVertSelChange(Sender: PObj); + procedure TextHorzSelChange(Sender: PObj); + procedure TextVertSelChange(Sender: PObj); + procedure Col1Paint(Sender: PControl; DC: HDC); + procedure CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); + procedure BorderWiEnter(Sender: PObj); + procedure BorderWiLeave(Sender: PObj); + procedure BorderHeLeave(Sender: PObj); + procedure GlyphXLeave(Sender: PObj); + procedure GlyphYLeave(Sender: PObj); + procedure GlyphWidthLeave(Sender: PObj); + procedure GlyphHeightLeave(Sender: PObj); + procedure SpacingLeave(Sender: PObj); + procedure LLeave(Sender: PObj); + procedure TLeave(Sender: PObj); + procedure RLeave(Sender: PObj); + procedure BLeave(Sender: PObj); + procedure ShadowOffsetLeave(Sender: PObj); + procedure BorderWidthLeave(Sender: PObj); + procedure GRushButton11Click(Sender: PObj); + procedure GRushButton16Click(Sender: PObj); + procedure GRushButton17Click(Sender: PObj); + procedure GRushButton19Click(Sender: PObj); + procedure GRushButton13Click(Sender: PObj); + procedure GRushButton10Click(Sender: PObj); + procedure GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); + procedure GRushButton9Click(Sender: PObj); + procedure GRushButton8Click(Sender: PObj); + procedure GRushButton7Click(Sender: PObj); + procedure GRushButton18Click(Sender: PObj); + procedure GRushButton1Click(Sender: PObj); + procedure GRushButton2Click(Sender: PObj); + procedure GRushButton3Click(Sender: PObj); + procedure GRushButton4Click(Sender: PObj); + procedure GRushButton5Click(Sender: PObj); + procedure GRushButton6Click(Sender: PObj); + procedure GRushButton14Click(Sender: PObj); + procedure GRushButton20Click(Sender: PObj); + procedure KOLForm1Close(Sender: PObj; var Accept: Boolean); + procedure GRushButton15Click(Sender: PObj); + procedure ButtonOKClick(Sender: PObj); + procedure ButtonCancelClick(Sender: PObj); + procedure CropTopFirstClick(Sender: PObj); + procedure GlyphAttachedClick(Sender: PObj); + procedure WordWrapClick(Sender: PObj); + procedure GRushButton12Click(Sender: PObj); + procedure GRushButton21Click(Sender: PObj); + procedure DotsCountLeave(Sender: PObj); + private + public + end; + +var SplitterEditor: PSplitterEditor; + +procedure Register; +procedure NewSplitterEditor(var Result: PSplitterEditor; Prop: TSplitterStylesProp); + +implementation + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TKOLGRushSplitterStyles), nil, '', TSplitterStylesProp); +end; + +procedure NewSplitterEditor(var Result: PSplitterEditor; Prop: TSplitterStylesProp); +begin + New(Result, Create); + Result.Form := NewForm(nil, 'SplitterEditor').SetPosition(193, 124).SetClientSize(520, 570); + Result.KOLForm1BeforeCreateWindow(Result); + Applet := Result.Form; + Result.Form.Add2AutoFree(Result); + Result.Form.ExStyle := Result.Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; + Result.Form.Style := Result.Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX); + Result.Form.Border := 0; + Result.Form.OnClose := Result.KOLForm1Close; + + tinyLoadJPGGIFBMPResource(Result.GRushImageCollection1, HINSTANCE, 'GRUSHIMAGECOLLECTION1', 'GRUSHCOLLECTIONS'); + + Result.CD1 := NewColorDialog(ccoFullOpen); + Result.Form.Add2AutoFree(Result.CD1); + Result.LabelState := NewLabel(Result.Form, 'State:').SetPosition(280, 12).SetSize(41, 17); + Result.ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetPosition(400, 512).SetSize(105, 33)); + Result.ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetPosition(272, 512).SetSize(105, 33)); + Result.ButtonOK.Font.FontStyle := [fsBold]; + Result.GRushButton15 := PGRushControl(NewGRushButton(Result.Form, 'Reset to souce').SetPosition(401, 408).SetSize(104, 17)); + Result.GRushButton15.Font.FontHeight := 8; + Result.GRushButton15.All_BorderRoundWidth := 0; + Result.GRushButton15.All_BorderRoundHeight := 0; + Result.GRushButton15.Down_BorderWidth := 1; + Result.GRushButton15.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton20 := PGRushControl(NewGRushButton(Result.Form, 'Reset to default').SetPosition(273, 408).SetSize(104, 17)); + Result.GRushButton20.Font.FontHeight := 8; + Result.GRushButton20.All_BorderRoundWidth := 0; + Result.GRushButton20.All_BorderRoundHeight := 0; + Result.GRushButton20.Down_BorderWidth := 1; + Result.GRushButton20.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.StatesList := NewComboBox(Result.Form, [coReadOnly, coNoIntegralHeight]).SetPosition(328, 10).SetSize(113, 0); + Result.StatesList.Font.FontHeight := 8; + Result.StatesList.Color := clWindow; + Result.StatesList.Items[0] := 'All states (w/o)'; + Result.StatesList.Items[1] := 'Default state'; + Result.StatesList.Items[2] := 'Over state'; + Result.StatesList.Items[3] := 'Down state'; + Result.StatesList.Items[4] := 'Disabled state'; + Result.StatesList.CurIndex := 0; + Result.GRushPanel1 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(8, 208).SetSize(249, 353)); + Result.GRushPanel1.Border := 2; + Result.GRushPanel1.Def_ColorFrom := 15259342; + Result.GRushPanel1.Def_ColorTo := 15259600; + Result.GRushPanel1.Def_BorderRoundWidth := 8; + Result.GRushPanel1.Def_BorderRoundHeight := 9; + Result.GRushPanel1.Def_GradientStyle := gsSolid; + Result.GRushPanel1.All_ShadowOffset := 0; + Result.Label16 := NewLabel(Result.GRushPanel1, 'L:').SetPosition(8, 248).SetSize(17, 17); + Result.Label16.TextAlign := taRight; + Result.Label16.Color := $E8D6CE; + Result.Label17 := NewLabel(Result.GRushPanel1, 'T:').SetPosition(68, 248).SetSize(17, 17); + Result.Label17.TextAlign := taRight; + Result.Label17.Color := $E8D6CE; + Result.Label18 := NewLabel(Result.GRushPanel1, 'Offsets of content').SetPosition(8, 224).SetSize(185, 17); + Result.Label18.Font.FontStyle := [fsBold]; + Result.Label18.TextAlign := taCenter; + Result.Label18.Color := $E8D6CE; + Result.Label19 := NewLabel(Result.GRushPanel1, 'R:').SetPosition(128, 248).SetSize(17, 17); + Result.Label19.TextAlign := taRight; + Result.Label19.Color := $E8D6CE; + Result.Label20 := NewLabel(Result.GRushPanel1, 'B:').SetPosition(188, 248).SetSize(17, 17); + Result.Label20.TextAlign := taRight; + Result.Label20.Color := $E8D6CE; + Result.Label21 := NewLabel(Result.GRushPanel1, 'Spacing:').SetPosition(8, 296).SetSize(97, 17); + Result.Label21.TextAlign := taRight; + Result.Label21.Color := $E8D6CE; + Result.Label22 := NewLabel(Result.GRushPanel1, 'Glyph size').SetPosition(8, 176).SetSize(185, 17); + Result.Label22.Font.FontStyle := [fsBold]; + Result.Label22.TextAlign := taCenter; + Result.Label22.Color := $E8D6CE; + Result.Label23 := NewLabel(Result.GRushPanel1, 'width:').SetPosition(8, 200).SetSize(65, 17); + Result.Label23.TextAlign := taRight; + Result.Label23.Color := $E8D6CE; + Result.Label24 := NewLabel(Result.GRushPanel1, 'height:').SetPosition(128, 200).SetSize(65, 17); + Result.Label24.TextAlign := taRight; + Result.Label24.Color := $E8D6CE; + Result.Label25 := NewLabel(Result.GRushPanel1, 'Update speed:').SetPosition(8, 320).SetSize(97, 17); + Result.Label25.TextAlign := taRight; + Result.Label25.Color := $E8D6CE; + Result.Label26 := NewLabel(Result.GRushPanel1, 'Glyph align').SetPosition(8, 80).SetSize(185, 17); + Result.Label26.Font.FontStyle := [fsBold]; + Result.Label26.TextAlign := taCenter; + Result.Label26.Color := $E8D6CE; + Result.Label27 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 104).SetSize(49, 17); + Result.Label27.TextAlign := taRight; + Result.Label27.Color := $E8D6CE; + Result.Label28 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 104).SetSize(49, 17); + Result.Label28.TextAlign := taRight; + Result.Label28.Color := $E8D6CE; + Result.Label29 := NewLabel(Result.GRushPanel1, 'Text align').SetPosition(8, 128).SetSize(185, 17); + Result.Label29.Font.FontStyle := [fsBold]; + Result.Label29.TextAlign := taCenter; + Result.Label29.Color := $E8D6CE; + Result.Label30 := NewLabel(Result.GRushPanel1, 'horz:').SetPosition(8, 152).SetSize(49, 17); + Result.Label30.TextAlign := taRight; + Result.Label30.Color := $E8D6CE; + Result.Label31 := NewLabel(Result.GRushPanel1, 'vert:').SetPosition(128, 152).SetSize(49, 17); + Result.Label31.TextAlign := taRight; + Result.Label31.Color := $E8D6CE; + Result.Label32 := NewLabel(Result.GRushPanel1, 'Dots count:').SetPosition(8, 272).SetSize(97, 17); + Result.Label32.TextAlign := taRight; + Result.Label32.Color := $E8D6CE; + Result.B := NewEditBox(Result.GRushPanel1, []).SetPosition(208, 248).SetSize(33, 17); + Result.B.Ctl3D := False; + Result.B.Font.FontHeight := 8; + Result.B.Text := '0'; + Result.DotsCount := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 272).SetSize(81, 17); + Result.DotsCount.Ctl3D := False; + Result.DotsCount.Font.FontHeight := 8; + Result.DotsCount.Text := '0'; + Result.GlyphHeight := NewEditBox(Result.GRushPanel1, []).SetPosition(200, 200).SetSize(41, 17); + Result.GlyphHeight.Ctl3D := False; + Result.GlyphHeight.Font.FontHeight := 8; + Result.GlyphHeight.Text := '0'; + Result.GlyphWidth := NewEditBox(Result.GRushPanel1, []).SetPosition(80, 200).SetSize(41, 17); + Result.GlyphWidth.Ctl3D := False; + Result.GlyphWidth.Font.FontHeight := 8; + Result.GlyphWidth.Text := '0'; + Result.L := NewEditBox(Result.GRushPanel1, []).SetPosition(28, 248).SetSize(33, 17); + Result.L.Ctl3D := False; + Result.L.Font.FontHeight := 8; + Result.L.Text := '0'; + Result.R := NewEditBox(Result.GRushPanel1, []).SetPosition(148, 248).SetSize(33, 17); + Result.R.Ctl3D := False; + Result.R.Font.FontHeight := 8; + Result.R.Text := '0'; + Result.Spacing := NewEditBox(Result.GRushPanel1, []).SetPosition(112, 296).SetSize(81, 17); + Result.Spacing.Ctl3D := False; + Result.Spacing.Font.FontHeight := 8; + Result.Spacing.Text := '0'; + Result.T := NewEditBox(Result.GRushPanel1, []).SetPosition(88, 248).SetSize(33, 17); + Result.T.Ctl3D := False; + Result.T.Font.FontHeight := 8; + Result.T.Text := '0'; + Result.GRushButton11 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton11.Font.FontHeight := 8; + Result.GRushButton11.All_BorderRoundWidth := 0; + Result.GRushButton11.All_BorderRoundHeight := 0; + Result.GRushButton11.Down_BorderWidth := 1; + Result.GRushButton11.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton12 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton12.Font.FontHeight := 8; + Result.GRushButton12.All_BorderRoundWidth := 0; + Result.GRushButton12.All_BorderRoundHeight := 0; + Result.GRushButton12.Down_BorderWidth := 1; + Result.GRushButton12.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton13 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton13.Font.FontHeight := 8; + Result.GRushButton13.All_BorderRoundWidth := 0; + Result.GRushButton13.All_BorderRoundHeight := 0; + Result.GRushButton13.Down_BorderWidth := 1; + Result.GRushButton13.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton16 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton16.Font.FontHeight := 8; + Result.GRushButton16.All_BorderRoundWidth := 0; + Result.GRushButton16.All_BorderRoundHeight := 0; + Result.GRushButton16.Down_BorderWidth := 1; + Result.GRushButton16.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton17 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton17.Font.FontHeight := 8; + Result.GRushButton17.All_BorderRoundWidth := 0; + Result.GRushButton17.All_BorderRoundHeight := 0; + Result.GRushButton17.Down_BorderWidth := 1; + Result.GRushButton17.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton19 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 320).SetSize(41, 17)); + Result.GRushButton19.Font.FontHeight := 8; + Result.GRushButton19.All_BorderRoundWidth := 0; + Result.GRushButton19.All_BorderRoundHeight := 0; + Result.GRushButton19.Down_BorderWidth := 1; + Result.GRushButton19.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton21 := PGRushControl(NewGRushButton(Result.GRushPanel1, 'Default').SetPosition(200, 272).SetSize(41, 17)); + Result.GRushButton21.Font.FontHeight := 8; + Result.GRushButton21.All_BorderRoundWidth := 0; + Result.GRushButton21.All_BorderRoundHeight := 0; + Result.GRushButton21.Down_BorderWidth := 1; + Result.GRushButton21.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GlyphHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 102).SetSize(57, 0); + Result.GlyphHorz.Font.FontHeight := 8; + Result.GlyphHorz.Color := clWindow; + Result.GlyphHorz.Items[0] := 'Left'; + Result.GlyphHorz.Items[1] := 'Center'; + Result.GlyphHorz.Items[2] := 'Right'; + Result.GlyphHorz.CurIndex := 0; + Result.GlyphVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 102).SetSize(57, 0); + Result.GlyphVert.Font.FontHeight := 8; + Result.GlyphVert.Color := clWindow; + Result.GlyphVert.Items[0] := 'Top'; + Result.GlyphVert.Items[1] := 'Center'; + Result.GlyphVert.Items[2] := 'Bottom'; + Result.GlyphVert.CurIndex := 0; + Result.TextHorz := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(64, 150).SetSize(57, 0); + Result.TextHorz.Font.FontHeight := 8; + Result.TextHorz.Color := clWindow; + Result.TextHorz.Items[0] := 'Left'; + Result.TextHorz.Items[1] := 'Center'; + Result.TextHorz.Items[2] := 'Right'; + Result.TextHorz.CurIndex := 0; + Result.TextVert := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(184, 150).SetSize(57, 0); + Result.TextVert.Font.FontHeight := 8; + Result.TextVert.Color := clWindow; + Result.TextVert.Items[0] := 'Top'; + Result.TextVert.Items[1] := 'Center'; + Result.TextVert.Items[2] := 'Bottom'; + Result.TextVert.CurIndex := 0; + Result.UpdateSpeed := NewComboBox(Result.GRushPanel1, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 318).SetSize(81, 21); + Result.UpdateSpeed.Font.FontHeight := 8; + Result.UpdateSpeed.Color := clWindow; + Result.UpdateSpeed.Items[0] := 'Immediately'; + Result.UpdateSpeed.Items[1] := 'Very fast'; + Result.UpdateSpeed.Items[2] := 'Fast'; + Result.UpdateSpeed.Items[3] := 'Normal'; + Result.UpdateSpeed.Items[4] := 'Slow'; + Result.UpdateSpeed.Items[5] := 'Very slow'; + Result.UpdateSpeed.CurIndex := 0; + Result.AntiAliasing := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Antialiasing').SetPosition(8, 8).SetSize(113, 17)); + Result.AntiAliasing.Down_ColorFrom := 14798527; + Result.AntiAliasing.Down_ColorTo := 16777215; + Result.AntiAliasing.All_ColorOuter := 15259342; + Result.AntiAliasing.All_ColorShadow := 12632256; + Result.AntiAliasing.Over_BorderColor := 8421504; + Result.AntiAliasing.Down_BorderWidth := 1; + Result.AntiAliasing.All_ShadowOffset := 0; + Result.CropTopFirst := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Crop top first').SetPosition(8, 32).SetSize(113, 17)); + Result.CropTopFirst.Enabled := False; + Result.CropTopFirst.Down_ColorFrom := 14798527; + Result.CropTopFirst.Down_ColorTo := 16777215; + Result.CropTopFirst.All_ColorOuter := 15259342; + Result.CropTopFirst.Dis_ColorText := 8421504; + Result.CropTopFirst.All_ColorShadow := 12632256; + Result.CropTopFirst.Over_BorderColor := 8421504; + Result.CropTopFirst.Down_BorderWidth := 1; + Result.CropTopFirst.All_ShadowOffset := 0; + Result.DrawGlyph := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw glyph').SetPosition(8, 56).SetSize(113, 17)); + Result.DrawGlyph.Down_ColorFrom := 14798527; + Result.DrawGlyph.Down_ColorTo := 16777215; + Result.DrawGlyph.All_ColorOuter := 15259342; + Result.DrawGlyph.All_ColorShadow := 12632256; + Result.DrawGlyph.Over_BorderColor := 8421504; + Result.DrawGlyph.Down_BorderWidth := 1; + Result.DrawGlyph.All_ShadowOffset := 0; + Result.DrawText := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Draw text').SetPosition(128, 56).SetSize(113, 17)); + Result.DrawText.Down_ColorFrom := 14798527; + Result.DrawText.Down_ColorTo := 16777215; + Result.DrawText.All_ColorOuter := 15259342; + Result.DrawText.All_ColorShadow := 12632256; + Result.DrawText.Over_BorderColor := 8421504; + Result.DrawText.Down_BorderWidth := 1; + Result.DrawText.All_ShadowOffset := 0; + Result.GlyphAttached := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Glyph attached').SetPosition(128, 32).SetSize(113, 17)); + Result.GlyphAttached.Enabled := False; + Result.GlyphAttached.Down_ColorFrom := 14798527; + Result.GlyphAttached.Down_ColorTo := 16777215; + Result.GlyphAttached.All_ColorOuter := 15259342; + Result.GlyphAttached.Dis_ColorText := 8421504; + Result.GlyphAttached.All_ColorShadow := 12632256; + Result.GlyphAttached.Over_BorderColor := 8421504; + Result.GlyphAttached.Down_BorderWidth := 1; + Result.GlyphAttached.All_ShadowOffset := 0; + Result.WordWrap := PGRushControl(NewGRushCheckBox(Result.GRushPanel1, 'Word wrap').SetPosition(128, 8).SetSize(113, 17)); + Result.WordWrap.Enabled := False; + Result.WordWrap.Down_ColorFrom := 14798527; + Result.WordWrap.Down_ColorTo := 16777215; + Result.WordWrap.All_ColorOuter := 15259342; + Result.WordWrap.All_ColorShadow := 12632256; + Result.WordWrap.Over_BorderColor := 8421504; + Result.WordWrap.Down_BorderWidth := 1; + Result.WordWrap.All_ShadowOffset := 0; + Result.GRushPanel2 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(264, 40).SetSize(249, 353)); + Result.GRushPanel2.Font.FontStyle := [fsBold]; + Result.GRushPanel2.Border := 2; + Result.GRushPanel2.Caption := 'State options'; + Result.GRushPanel2.Def_ColorFrom := 15259342; + Result.GRushPanel2.Def_ColorTo := 15259600; + Result.GRushPanel2.Def_BorderRoundWidth := 8; + Result.GRushPanel2.Def_BorderRoundHeight := 9; + Result.GRushPanel2.Def_GradientStyle := gsSolid; + Result.GRushPanel2.All_ShadowOffset := 0; + Result.GRushPanel2.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel2.All_TextHAlign := haLeft; + Result.Col1 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 32).SetSize(49, 17); + Result.Col1.Font.FontStyle := []; + Result.Col1.Color := clSilver; + Result.Col2 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 56).SetSize(49, 17); + Result.Col2.Font.FontStyle := []; + Result.Col2.Color := clSilver; + Result.Col3 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 80).SetSize(49, 17); + Result.Col3.Font.FontStyle := []; + Result.Col3.Color := clSilver; + Result.Col4 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 104).SetSize(49, 17); + Result.Col4.Font.FontStyle := []; + Result.Col4.Color := clSilver; + Result.Col5 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 128).SetSize(49, 17); + Result.Col5.Font.FontStyle := []; + Result.Col5.Color := clSilver; + Result.Col6 := NewLabel(Result.GRushPanel2, '').SetPosition(128, 152).SetSize(49, 17); + Result.Col6.Font.FontStyle := []; + Result.Col6.Color := clSilver; + Result.Label1 := NewLabel(Result.GRushPanel2, 'Border color:').SetPosition(8, 104).SetSize(97, 17); + Result.Label1.Font.FontStyle := []; + Result.Label1.TextAlign := taRight; + Result.Label1.Color := $E8D6CE; + Result.Label10 := NewLabel(Result.GRushPanel2, 'by X:').SetPosition(8, 320).SetSize(65, 17); + Result.Label10.Font.FontStyle := []; + Result.Label10.TextAlign := taRight; + Result.Label10.Color := $E8D6CE; + Result.Label11 := NewLabel(Result.GRushPanel2, 'Border width:').SetPosition(8, 200).SetSize(97, 17); + Result.Label11.Font.FontStyle := []; + Result.Label11.TextAlign := taRight; + Result.Label11.Color := $E8D6CE; + Result.Label12 := NewLabel(Result.GRushPanel2, 'Border ellipse').SetPosition(8, 248).SetSize(185, 17); + Result.Label12.TextAlign := taCenter; + Result.Label12.Color := $E8D6CE; + Result.Label13 := NewLabel(Result.GRushPanel2, 'width:').SetPosition(8, 272).SetSize(65, 17); + Result.Label13.Font.FontStyle := []; + Result.Label13.TextAlign := taRight; + Result.Label13.Color := $E8D6CE; + Result.Label14 := NewLabel(Result.GRushPanel2, 'height:').SetPosition(128, 272).SetSize(65, 17); + Result.Label14.Font.FontStyle := []; + Result.Label14.TextAlign := taRight; + Result.Label14.Color := $E8D6CE; + Result.Label15 := NewLabel(Result.GRushPanel2, 'by Y:').SetPosition(128, 320).SetSize(65, 17); + Result.Label15.Font.FontStyle := []; + Result.Label15.TextAlign := taRight; + Result.Label15.Color := $E8D6CE; + Result.Label2 := NewLabel(Result.GRushPanel2, 'From color:').SetPosition(8, 56).SetSize(97, 17); + Result.Label2.Font.FontStyle := []; + Result.Label2.TextAlign := taRight; + Result.Label2.Color := $E8D6CE; + Result.Label3 := NewLabel(Result.GRushPanel2, 'To color:').SetPosition(8, 80).SetSize(97, 17); + Result.Label3.Font.FontStyle := []; + Result.Label3.TextAlign := taRight; + Result.Label3.Color := $E8D6CE; + Result.Label4 := NewLabel(Result.GRushPanel2, 'Outer color:').SetPosition(8, 32).SetSize(97, 17); + Result.Label4.Font.FontStyle := []; + Result.Label4.TextAlign := taRight; + Result.Label4.Color := $E8D6CE; + Result.Label5 := NewLabel(Result.GRushPanel2, 'Text color:').SetPosition(8, 128).SetSize(97, 17); + Result.Label5.Font.FontStyle := []; + Result.Label5.TextAlign := taRight; + Result.Label5.Color := $E8D6CE; + Result.Label6 := NewLabel(Result.GRushPanel2, 'Shadow color:').SetPosition(8, 152).SetSize(97, 17); + Result.Label6.Font.FontStyle := []; + Result.Label6.TextAlign := taRight; + Result.Label6.Color := $E8D6CE; + Result.Label7 := NewLabel(Result.GRushPanel2, 'Gradient style:').SetPosition(8, 176).SetSize(97, 17); + Result.Label7.Font.FontStyle := []; + Result.Label7.TextAlign := taRight; + Result.Label7.Color := $E8D6CE; + Result.Label8 := NewLabel(Result.GRushPanel2, 'Shadow offset:').SetPosition(8, 224).SetSize(97, 17); + Result.Label8.Font.FontStyle := []; + Result.Label8.TextAlign := taRight; + Result.Label8.Color := $E8D6CE; + Result.Label9 := NewLabel(Result.GRushPanel2, 'Glyph item').SetPosition(8, 296).SetSize(185, 17); + Result.Label9.TextAlign := taCenter; + Result.Label9.Color := $E8D6CE; + Result.BorderHe := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 272).SetSize(41, 17); + Result.BorderHe.Ctl3D := False; + Result.BorderHe.Font.FontStyle := []; + Result.BorderHe.Font.FontHeight := 8; + Result.BorderWi := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 272).SetSize(41, 17); + Result.BorderWi.Ctl3D := False; + Result.BorderWi.Font.FontStyle := []; + Result.BorderWi.Font.FontHeight := 8; + Result.BorderWidth := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 200).SetSize(81, 17); + Result.BorderWidth.Ctl3D := False; + Result.BorderWidth.Font.FontStyle := []; + Result.BorderWidth.Font.FontHeight := 8; + Result.GlyphX := NewEditBox(Result.GRushPanel2, []).SetPosition(80, 320).SetSize(41, 17); + Result.GlyphX.Ctl3D := False; + Result.GlyphX.Font.FontStyle := []; + Result.GlyphX.Font.FontHeight := 8; + Result.GlyphY := NewEditBox(Result.GRushPanel2, []).SetPosition(200, 320).SetSize(41, 17); + Result.GlyphY.Ctl3D := False; + Result.GlyphY.Font.FontStyle := []; + Result.GlyphY.Font.FontHeight := 8; + Result.ShadowOffset := NewEditBox(Result.GRushPanel2, []).SetPosition(112, 224).SetSize(81, 17); + Result.ShadowOffset.Ctl3D := False; + Result.ShadowOffset.Font.FontStyle := []; + Result.ShadowOffset.Font.FontHeight := 8; + Result.GRushButton1 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 32).SetSize(41, 17)); + Result.GRushButton1.Font.FontStyle := []; + Result.GRushButton1.Font.FontHeight := 8; + Result.GRushButton1.All_BorderRoundWidth := 0; + Result.GRushButton1.All_BorderRoundHeight := 0; + Result.GRushButton1.Down_BorderWidth := 1; + Result.GRushButton1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton10 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 296).SetSize(41, 17)); + Result.GRushButton10.Font.FontStyle := []; + Result.GRushButton10.Font.FontHeight := 8; + Result.GRushButton10.All_BorderRoundWidth := 0; + Result.GRushButton10.All_BorderRoundHeight := 0; + Result.GRushButton10.Down_BorderWidth := 1; + Result.GRushButton10.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton14 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Reset state').SetPosition(176, 4).SetSize(65, 17)); + Result.GRushButton14.Font.FontStyle := []; + Result.GRushButton14.Font.FontHeight := 8; + Result.GRushButton14.All_BorderRoundWidth := 0; + Result.GRushButton14.All_BorderRoundHeight := 0; + Result.GRushButton14.Down_BorderWidth := 1; + Result.GRushButton14.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton18 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 176).SetSize(41, 17)); + Result.GRushButton18.Font.FontStyle := []; + Result.GRushButton18.Font.FontHeight := 8; + Result.GRushButton18.All_BorderRoundWidth := 0; + Result.GRushButton18.All_BorderRoundHeight := 0; + Result.GRushButton18.Down_BorderWidth := 1; + Result.GRushButton18.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton2 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 56).SetSize(41, 17)); + Result.GRushButton2.Font.FontStyle := []; + Result.GRushButton2.Font.FontHeight := 8; + Result.GRushButton2.All_BorderRoundWidth := 0; + Result.GRushButton2.All_BorderRoundHeight := 0; + Result.GRushButton2.Down_BorderWidth := 1; + Result.GRushButton2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton3 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 80).SetSize(41, 17)); + Result.GRushButton3.Font.FontStyle := []; + Result.GRushButton3.Font.FontHeight := 8; + Result.GRushButton3.All_BorderRoundWidth := 0; + Result.GRushButton3.All_BorderRoundHeight := 0; + Result.GRushButton3.Down_BorderWidth := 1; + Result.GRushButton3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton4 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 104).SetSize(41, 17)); + Result.GRushButton4.Font.FontStyle := []; + Result.GRushButton4.Font.FontHeight := 8; + Result.GRushButton4.All_BorderRoundWidth := 0; + Result.GRushButton4.All_BorderRoundHeight := 0; + Result.GRushButton4.Down_BorderWidth := 1; + Result.GRushButton4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton5 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 128).SetSize(41, 17)); + Result.GRushButton5.Font.FontStyle := []; + Result.GRushButton5.Font.FontHeight := 8; + Result.GRushButton5.All_BorderRoundWidth := 0; + Result.GRushButton5.All_BorderRoundHeight := 0; + Result.GRushButton5.Down_BorderWidth := 1; + Result.GRushButton5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton6 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 152).SetSize(41, 17)); + Result.GRushButton6.Font.FontStyle := []; + Result.GRushButton6.Font.FontHeight := 8; + Result.GRushButton6.All_BorderRoundWidth := 0; + Result.GRushButton6.All_BorderRoundHeight := 0; + Result.GRushButton6.Down_BorderWidth := 1; + Result.GRushButton6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton7 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 200).SetSize(41, 17)); + Result.GRushButton7.Font.FontStyle := []; + Result.GRushButton7.Font.FontHeight := 8; + Result.GRushButton7.All_BorderRoundWidth := 0; + Result.GRushButton7.All_BorderRoundHeight := 0; + Result.GRushButton7.Down_BorderWidth := 1; + Result.GRushButton7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton8 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 224).SetSize(41, 17)); + Result.GRushButton8.Font.FontStyle := []; + Result.GRushButton8.Font.FontHeight := 8; + Result.GRushButton8.All_BorderRoundWidth := 0; + Result.GRushButton8.All_BorderRoundHeight := 0; + Result.GRushButton8.Down_BorderWidth := 1; + Result.GRushButton8.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GRushButton9 := PGRushControl(NewGRushButton(Result.GRushPanel2, 'Default').SetPosition(200, 248).SetSize(41, 17)); + Result.GRushButton9.Font.FontStyle := []; + Result.GRushButton9.Font.FontHeight := 8; + Result.GRushButton9.All_BorderRoundWidth := 0; + Result.GRushButton9.All_BorderRoundHeight := 0; + Result.GRushButton9.Down_BorderWidth := 1; + Result.GRushButton9.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.GradStyles := NewComboBox(Result.GRushPanel2, [coReadOnly, coNoIntegralHeight]).SetPosition(112, 174).SetSize(81, 0); + Result.GradStyles.Font.FontStyle := []; + Result.GradStyles.Font.FontHeight := 8; + Result.GradStyles.Color := clWindow; + Result.GradStyles.Items[0] := 'Solid'; + Result.GradStyles.Items[1] := 'Vertical'; + Result.GradStyles.Items[2] := 'Horizontal'; + Result.GradStyles.Items[3] := 'Double vertical'; + Result.GradStyles.Items[4] := 'Double horizontal'; + Result.GradStyles.Items[5] := 'From top left'; + Result.GradStyles.Items[6] := 'From top right'; + Result.GradStyles.CurIndex := 0; + Result.GRushPanel3 := PGRushControl(NewGRushPanel(Result.Form).SetPosition(7, 8).SetSize(249, 193)); + Result.GRushPanel3.Font.FontStyle := [fsBold]; + Result.GRushPanel3.Border := 2; + Result.GRushPanel3.Caption := 'Sample control'; + Result.GRushPanel3.Def_ColorFrom := -2147483633; + Result.GRushPanel3.Def_ColorTo := 15259600; + Result.GRushPanel3.Def_BorderRoundWidth := 8; + Result.GRushPanel3.Def_BorderRoundHeight := 9; + Result.GRushPanel3.Def_GradientStyle := gsSolid; + Result.GRushPanel3.All_ShadowOffset := 0; + Result.GRushPanel3.All_ContentOffsets := MakeRect(12, 4, -4, -4); + Result.GRushPanel3.All_TextHAlign := haLeft; + Result.Caption := NewEditBox(Result.GRushPanel3, []).SetPosition(8, 168).SetSize(233, 17); + Result.Caption.Ctl3D := False; + Result.Caption.Font.FontStyle := []; + Result.Control := PGRushControl(NewGRushButton(Result.GRushPanel3, '').SetPosition(8, 24).SetSize(233, 113)); + Result.Control.Font.FontStyle := []; + Result.Control.Cursor := LoadCursor(0, IDC_SIZENS); + Result.Control.Def_ColorFrom := -2147483633; + Result.Control.Over_ColorFrom := 16777215; + Result.Control.Down_ColorFrom := 16777215; + Result.Control.Over_ColorTo := 13675925; + Result.Control.Down_ColorTo := 12817525; + Result.Control.All_BorderRoundWidth := 0; + Result.Control.All_BorderRoundHeight := 0; + Result.Control.All_BorderWidth := 0; + Result.Control.Def_GradientStyle := gsSolid; + Result.Control.Over_GradientStyle := gsVertical; + Result.Control.Down_GradientStyle := gsVertical; + Result.Control.Dis_GradientStyle := gsVertical; + Result.Control.All_DrawFocusRect := FALSE; + Result.Control.All_UpdateSpeed := usVeryFast; + Result.CheckEnabled := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Enabled').SetPosition(8, 144).SetSize(113, 17)); + Result.CheckEnabled.Font.FontStyle := []; + Result.CheckEnabled.Checked := TRUE; + Result.CheckEnabled.Down_ColorFrom := 14798527; + Result.CheckEnabled.Down_ColorTo := 16777215; + Result.CheckEnabled.All_ColorShadow := 12632256; + Result.CheckEnabled.Over_BorderColor := 8421504; + Result.CheckEnabled.Down_BorderWidth := 1; + Result.CheckEnabled.Down_ShadowOffset := 1; + Result.CheckEnabled.Dis_ShadowOffset := 1; + Result.CheckTransparent := PGRushControl(NewGRushCheckBox(Result.GRushPanel3, 'Transparent').SetPosition(128, 144).SetSize(113, 17)); + Result.CheckTransparent.Font.FontStyle := []; + Result.CheckTransparent.Down_ColorFrom := 14798527; + Result.CheckTransparent.Down_ColorTo := 16777215; + Result.CheckTransparent.All_ColorShadow := 12632256; + Result.CheckTransparent.Over_BorderColor := 8421504; + Result.CheckTransparent.Down_BorderWidth := 1; + Result.CheckTransparent.Down_ShadowOffset := 1; + Result.CheckTransparent.Dis_ShadowOffset := 1; + Result.Down1 := PGRushControl(NewGRushButton(Result.StatesList, '').SetPosition(94, 1).SetSize(18, 19)); + Result.Down1.All_BorderRoundWidth := 0; + Result.Down1.All_BorderRoundHeight := 0; + Result.Down1.Down_BorderWidth := 1; + Result.Down1.Dis_BorderWidth := 1; + Result.Down1.Def_ShadowOffset := 0; + Result.Down1.Over_ShadowOffset := 0; + Result.Down1.Down_ShadowOffset := 255; + Result.Down1.Dis_ShadowOffset := 0; + Result.Down1.Over_GlyphItemY := 1; + Result.Down1.Down_GlyphItemY := 2; + Result.Down1.Dis_GlyphItemY := 3; + Result.Down1.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down1.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down1.All_GlyphWidth := 12; + Result.Down1.All_GlyphHeight := 12; + Result.Down1.All_GlyphHAlign := haCenter; + Result.Down1.All_Spacing := 0; + Result.Down1.All_DrawFocusRect := FALSE; + Result.Down2 := PGRushControl(NewGRushButton(Result.GradStyles, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down2.All_BorderRoundWidth := 0; + Result.Down2.All_BorderRoundHeight := 0; + Result.Down2.Down_BorderWidth := 1; + Result.Down2.Dis_BorderWidth := 1; + Result.Down2.Def_ShadowOffset := 0; + Result.Down2.Over_ShadowOffset := 0; + Result.Down2.Down_ShadowOffset := 255; + Result.Down2.Dis_ShadowOffset := 0; + Result.Down2.Over_GlyphItemY := 1; + Result.Down2.Down_GlyphItemY := 2; + Result.Down2.Dis_GlyphItemY := 3; + Result.Down2.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down2.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down2.All_GlyphWidth := 12; + Result.Down2.All_GlyphHeight := 12; + Result.Down2.All_GlyphHAlign := haCenter; + Result.Down2.All_Spacing := 0; + Result.Down2.All_DrawFocusRect := FALSE; + Result.Down3 := PGRushControl(NewGRushButton(Result.UpdateSpeed, '').SetPosition(62, 1).SetSize(18, 19)); + Result.Down3.All_BorderRoundWidth := 0; + Result.Down3.All_BorderRoundHeight := 0; + Result.Down3.Down_BorderWidth := 1; + Result.Down3.Dis_BorderWidth := 1; + Result.Down3.Def_ShadowOffset := 0; + Result.Down3.Over_ShadowOffset := 0; + Result.Down3.Down_ShadowOffset := 255; + Result.Down3.Dis_ShadowOffset := 0; + Result.Down3.Over_GlyphItemY := 1; + Result.Down3.Down_GlyphItemY := 2; + Result.Down3.Dis_GlyphItemY := 3; + Result.Down3.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down3.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down3.All_GlyphWidth := 12; + Result.Down3.All_GlyphHeight := 12; + Result.Down3.All_GlyphHAlign := haCenter; + Result.Down3.All_Spacing := 0; + Result.Down3.All_DrawFocusRect := FALSE; + Result.Down4 := PGRushControl(NewGRushButton(Result.GlyphHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down4.All_BorderRoundWidth := 0; + Result.Down4.All_BorderRoundHeight := 0; + Result.Down4.Down_BorderWidth := 1; + Result.Down4.Dis_BorderWidth := 1; + Result.Down4.Def_ShadowOffset := 0; + Result.Down4.Over_ShadowOffset := 0; + Result.Down4.Down_ShadowOffset := 255; + Result.Down4.Dis_ShadowOffset := 0; + Result.Down4.Over_GlyphItemY := 1; + Result.Down4.Down_GlyphItemY := 2; + Result.Down4.Dis_GlyphItemY := 3; + Result.Down4.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down4.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down4.All_GlyphWidth := 12; + Result.Down4.All_GlyphHeight := 12; + Result.Down4.All_GlyphHAlign := haCenter; + Result.Down4.All_Spacing := 0; + Result.Down4.All_DrawFocusRect := FALSE; + Result.Down5 := PGRushControl(NewGRushButton(Result.GlyphVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down5.All_BorderRoundWidth := 0; + Result.Down5.All_BorderRoundHeight := 0; + Result.Down5.Down_BorderWidth := 1; + Result.Down5.Dis_BorderWidth := 1; + Result.Down5.Def_ShadowOffset := 0; + Result.Down5.Over_ShadowOffset := 0; + Result.Down5.Down_ShadowOffset := 255; + Result.Down5.Dis_ShadowOffset := 0; + Result.Down5.Over_GlyphItemY := 1; + Result.Down5.Down_GlyphItemY := 2; + Result.Down5.Dis_GlyphItemY := 3; + Result.Down5.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down5.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down5.All_GlyphWidth := 12; + Result.Down5.All_GlyphHeight := 12; + Result.Down5.All_GlyphHAlign := haCenter; + Result.Down5.All_Spacing := 0; + Result.Down5.All_DrawFocusRect := FALSE; + Result.Down6 := PGRushControl(NewGRushButton(Result.TextHorz, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down6.All_BorderRoundWidth := 0; + Result.Down6.All_BorderRoundHeight := 0; + Result.Down6.Down_BorderWidth := 1; + Result.Down6.Dis_BorderWidth := 1; + Result.Down6.Def_ShadowOffset := 0; + Result.Down6.Over_ShadowOffset := 0; + Result.Down6.Down_ShadowOffset := 255; + Result.Down6.Dis_ShadowOffset := 0; + Result.Down6.Over_GlyphItemY := 1; + Result.Down6.Down_GlyphItemY := 2; + Result.Down6.Dis_GlyphItemY := 3; + Result.Down6.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down6.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down6.All_GlyphWidth := 12; + Result.Down6.All_GlyphHeight := 12; + Result.Down6.All_GlyphHAlign := haCenter; + Result.Down6.All_Spacing := 0; + Result.Down6.All_DrawFocusRect := FALSE; + Result.Down7 := PGRushControl(NewGRushButton(Result.TextVert, '').SetPosition(38, 1).SetSize(18, 19)); + Result.Down7.All_BorderRoundWidth := 0; + Result.Down7.All_BorderRoundHeight := 0; + Result.Down7.Down_BorderWidth := 1; + Result.Down7.Dis_BorderWidth := 1; + Result.Down7.Def_ShadowOffset := 0; + Result.Down7.Over_ShadowOffset := 0; + Result.Down7.Down_ShadowOffset := 255; + Result.Down7.Dis_ShadowOffset := 0; + Result.Down7.Over_GlyphItemY := 1; + Result.Down7.Down_GlyphItemY := 2; + Result.Down7.Dis_GlyphItemY := 3; + Result.Down7.All_ContentOffsets := MakeRect(0, 0, 0, 0); + Result.Down7.All_GlyphBitmap := Result.GRushImageCollection1; + Result.Down7.All_GlyphWidth := 12; + Result.Down7.All_GlyphHeight := 12; + Result.Down7.All_GlyphHAlign := haCenter; + Result.Down7.All_Spacing := 0; + Result.Down7.All_DrawFocusRect := FALSE; + + Result.Prop := Prop; + with Result^ do begin + Styles := TKOLGRushSplitterStyles(Prop.GetOrdValue); + Component := (Styles.Owner as MCKGRushControls.TKOLGRushSplitter); + TryResize(Control, Component.Width, Component.Height); + if Assigned(Component.imagecollection) then begin + Control.All_GlyphBitmap := Component.imagecollection.LoadBitmap; + Control.All_GlyphBitmap.Free; + end; + Control.Caption := Component.Caption; + Caption.Caption := Component.Caption; + Control.Font.FontHeight := Component.Font.FontHeight; + Control.Font.FontWidth := Component.Font.FontWidth; + //Control.Font.FontPitch := Component.Font.FontPitch; + Control.Font.FontStyle := KOL.TFontStyle(Component.Font.FontStyle); + Control.Font.FontCharset := Component.Font.FontCharset; + //Control.Font.FontQuality := Component.Font.FontQuality; + Control.Font.FontOrientation := Component.Font.FontOrientation; + Control.Font.FontWeight := Component.Font.FontWeight; + Control.Font.FontName := Component.Font.FontName; + end; + + Result.Col1.OnClick := Result.Col1Click; + Result.Col1.OnPaint := Result.Col1Paint; + Result.Col2.OnClick := Result.Col2Click; + Result.Col2.OnPaint := Result.Col1Paint; + Result.Col3.OnClick := Result.Col3Click; + Result.Col3.OnPaint := Result.Col1Paint; + Result.Col4.OnClick := Result.Col4Click; + Result.Col4.OnPaint := Result.Col1Paint; + Result.Col5.OnClick := Result.Col5Click; + Result.Col5.OnPaint := Result.Col1Paint; + Result.Col6.OnClick := Result.Col6Click; + Result.Col6.OnPaint := Result.Col1Paint; + Result.B.Color := clWindow; + Result.B.OnEnter := Result.BorderWiEnter; + Result.B.OnLeave := Result.BLeave; + Result.BorderHe.Color := clWindow; + Result.BorderHe.OnEnter := Result.BorderWiEnter; + Result.BorderHe.OnLeave := Result.BorderHeLeave; + Result.BorderWi.Color := clWindow; + Result.BorderWi.OnEnter := Result.BorderWiEnter; + Result.BorderWi.OnLeave := Result.BorderWiLeave; + Result.BorderWidth.Color := clWindow; + Result.BorderWidth.OnEnter := Result.BorderWiEnter; + Result.BorderWidth.OnLeave := Result.BorderWidthLeave; + Result.ButtonCancel.OnClick := Result.ButtonCancelClick; + Result.GRushImageCollection1.Free; + Result.ButtonOK.OnClick := Result.ButtonOKClick; + Result.Caption.Color := clWindow; + Result.Caption.OnChange := Result.CaptionChange; + Result.DotsCount.Color := clWindow; + Result.DotsCount.OnEnter := Result.BorderWiEnter; + Result.DotsCount.OnLeave := Result.DotsCountLeave; + Result.GlyphHeight.Color := clWindow; + Result.GlyphHeight.OnEnter := Result.BorderWiEnter; + Result.GlyphHeight.OnLeave := Result.GlyphHeightLeave; + Result.GlyphWidth.Color := clWindow; + Result.GlyphWidth.OnEnter := Result.BorderWiEnter; + Result.GlyphWidth.OnLeave := Result.GlyphWidthLeave; + Result.GlyphX.Color := clWindow; + Result.GlyphX.OnEnter := Result.BorderWiEnter; + Result.GlyphX.OnLeave := Result.GlyphXLeave; + Result.GlyphY.Color := clWindow; + Result.GlyphY.OnEnter := Result.BorderWiEnter; + Result.GlyphY.OnLeave := Result.GlyphYLeave; + Result.L.Color := clWindow; + Result.L.OnEnter := Result.BorderWiEnter; + Result.L.OnLeave := Result.LLeave; + Result.R.Color := clWindow; + Result.R.OnEnter := Result.BorderWiEnter; + Result.R.OnLeave := Result.RLeave; + Result.ShadowOffset.Color := clWindow; + Result.ShadowOffset.OnEnter := Result.BorderWiEnter; + Result.ShadowOffset.OnLeave := Result.ShadowOffsetLeave; + Result.Spacing.Color := clWindow; + Result.Spacing.OnEnter := Result.BorderWiEnter; + Result.Spacing.OnLeave := Result.SpacingLeave; + Result.T.Color := clWindow; + Result.T.OnEnter := Result.BorderWiEnter; + Result.T.OnLeave := Result.TLeave; + Result.Down1.OnClick := Result.Down1Click; + Result.Down2.OnClick := Result.Down2Click; + Result.Down3.OnClick := Result.Down3Click; + Result.Down4.OnClick := Result.Down4Click; + Result.Down5.OnClick := Result.Down5Click; + Result.Down6.OnClick := Result.Down6Click; + Result.Down7.OnClick := Result.Down7Click; + Result.GRushButton1.OnClick := Result.GRushButton1Click; + Result.GRushButton10.OnClick := Result.GRushButton10Click; + Result.GRushButton11.OnClick := Result.GRushButton11Click; + Result.GRushButton12.OnClick := Result.GRushButton12Click; + Result.GRushButton13.OnClick := Result.GRushButton13Click; + Result.GRushButton14.OnClick := Result.GRushButton14Click; + Result.GRushButton15.OnClick := Result.GRushButton15Click; + Result.GRushButton16.OnClick := Result.GRushButton16Click; + Result.GRushButton17.OnClick := Result.GRushButton17Click; + Result.GRushButton18.OnClick := Result.GRushButton18Click; + Result.GRushButton19.OnClick := Result.GRushButton19Click; + Result.GRushButton2.OnClick := Result.GRushButton2Click; + Result.GRushButton20.OnClick := Result.GRushButton20Click; + Result.GRushButton21.OnClick := Result.GRushButton21Click; + Result.GRushButton3.OnClick := Result.GRushButton3Click; + Result.GRushButton4.OnClick := Result.GRushButton4Click; + Result.GRushButton5.OnClick := Result.GRushButton5Click; + Result.GRushButton6.OnClick := Result.GRushButton6Click; + Result.GRushButton7.OnClick := Result.GRushButton7Click; + Result.GRushButton8.OnClick := Result.GRushButton8Click; + Result.GRushButton9.OnClick := Result.GRushButton9Click; + Result.GlyphHorz.OnSelChange := Result.GlyphHorzSelChange; + Result.GlyphVert.OnSelChange := Result.GlyphVertSelChange; + Result.GradStyles.OnSelChange := Result.GradStylesSelChange; + Result.StatesList.OnSelChange := Result.StatesListSelChange; + Result.TextHorz.OnSelChange := Result.TextHorzSelChange; + Result.TextVert.OnSelChange := Result.TextVertSelChange; + Result.UpdateSpeed.OnSelChange := Result.UpdateSpeedSelChange; + Result.AntiAliasing.OnClick := Result.AntiAliasingClick; + Result.AntiAliasing.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckEnabled.OnClick := Result.CheckEnabledClick; + Result.CheckEnabled.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CheckTransparent.OnClick := Result.CheckTransparentClick; + Result.CheckTransparent.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.CropTopFirst.OnClick := Result.CropTopFirstClick; + Result.CropTopFirst.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawGlyph.OnClick := Result.DrawGlyphClick; + Result.DrawGlyph.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.DrawText.OnClick := Result.DrawTextClick; + Result.DrawText.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GlyphAttached.OnClick := Result.GlyphAttachedClick; + Result.GlyphAttached.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.GRushPanel3.OnMouseDown := Result.GRushPanel3MouseDown; + Result.WordWrap.OnClick := Result.WordWrapClick; + Result.WordWrap.OnRecalcRects := Result.CheckEnabledRecalcRects; + Result.Form.CenterOnParent.CanResize := False; + Result.GRushButton15Click(Result.GRushButton15); + Result.Form.Icon := THandle(-1); + +end; + +procedure TSplitterEditor.KOLForm1BeforeCreateWindow(Sender: PObj); +begin + Form.Font; +end; + +procedure TSplitterEditor.KOLForm1FormCreate(Sender: PObj); +begin + + StatesList.CurIndex := 1; + StatesListSelChange(StatesList); + + Antialiasing.Checked := Control.All_AntiAliasing; + CropTopFirst.Checked := Control.All_CropTopFirst; + GlyphAttached.Checked := Control.All_GlyphAttached; + DrawGlyph.Checked := Control.All_DrawGlyph; + DrawText.Checked := Control.All_DrawText; + WordWrap.Checked := TRUE; + GlyphHorz.CurIndex := Integer(Control.All_GlyphHAlign); + GlyphVert.CurIndex := Integer(Control.All_GlyphVAlign); + TextHorz.CurIndex := Integer(Control.All_TextHAlign); + TextVert.CurIndex := Integer(Control.All_TextVAlign); + GlyphWidth.Text := int2str(Control.All_GlyphWidth); + GlyphHeight.Text := int2str(Control.All_GlyphHeight); + L.Text := int2str(Control.All_ContentOffsets.Left); + T.Text := int2str(Control.All_ContentOffsets.Top); + R.Text := int2str(Control.All_ContentOffsets.Right); + B.Text := int2str(Control.All_ContentOffsets.Bottom); + Spacing.Text := int2str(Control.All_Spacing); + DotsCount.Text := int2str(Control.All_SplitterDotsCount); + UpdateSpeed.CurIndex := Integer(Control.All_UpdateSpeed); +end; + +procedure TSplitterEditor.Down1Click(Sender: PObj); +begin + StatesList.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.Down2Click(Sender: PObj); +begin + GradStyles.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.CheckEnabledClick(Sender: PObj); +begin + Control.Enabled := CheckEnabled.Checked; +end; + +procedure TSplitterEditor.CheckTransparentClick(Sender: PObj); +begin + Control.Transparent := CheckTransparent.Checked; + Control.Invalidate; +end; + +procedure TSplitterEditor.Down3Click(Sender: PObj); +begin + UpdateSpeed.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.Down4Click(Sender: PObj); +begin + GlyphHorz.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.Down5Click(Sender: PObj); +begin + GlyphVert.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.Down6Click(Sender: PObj); +begin + TextHorz.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.Down7Click(Sender: PObj); +begin + TextVert.DroppedDown := TRUE; +end; + +procedure TSplitterEditor.GradStylesSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 2: + begin + Control.Over_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 3: + begin + Control.Down_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 4: + begin + Control.Dis_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + 0: + begin + Control.All_GradientStyle := TGRushGradientStyle(GradStyles.CurIndex); + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.Def_ColorOuter := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorOuter; + if CD1.Execute then + Control.Over_ColorOuter := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorOuter; + if CD1.Execute then + Control.Down_ColorOuter := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorOuter; + if CD1.Execute then + Control.Dis_ColorOuter := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorOuter; + if CD1.Execute then + Control.All_ColorOuter := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col1.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.Def_ColorFrom := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorFrom; + if CD1.Execute then + Control.Over_ColorFrom := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorFrom; + if CD1.Execute then + Control.Down_ColorFrom := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorFrom; + if CD1.Execute then + Control.Dis_ColorFrom := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorFrom; + if CD1.Execute then + Control.All_ColorFrom := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col2.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.Def_ColorTo := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorTo; + if CD1.Execute then + Control.Over_ColorTo := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorTo; + if CD1.Execute then + Control.Down_ColorTo := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorTo; + if CD1.Execute then + Control.Dis_ColorTo := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorTo; + if CD1.Execute then + Control.All_ColorTo := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col3.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.Def_BorderColor := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_BorderColor; + if CD1.Execute then + Control.Over_BorderColor := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_BorderColor; + if CD1.Execute then + Control.Down_BorderColor := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_BorderColor; + if CD1.Execute then + Control.Dis_BorderColor := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_BorderColor; + if CD1.Execute then + Control.All_BorderColor := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col4.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.Def_ColorText := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorText; + if CD1.Execute then + Control.Over_ColorText := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorText; + if CD1.Execute then + Control.Down_ColorText := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorText; + if CD1.Execute then + Control.Dis_ColorText := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorText; + if CD1.Execute then + Control.All_ColorText := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col5.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.Col6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.Def_ColorShadow := CD1.Color; + end; + 2: + begin + CD1.Color := Control.Over_ColorShadow; + if CD1.Execute then + Control.Over_ColorShadow := CD1.Color; + end; + 3: + begin + CD1.Color := Control.Down_ColorShadow; + if CD1.Execute then + Control.Down_ColorShadow := CD1.Color; + end; + 4: + begin + CD1.Color := Control.Dis_ColorShadow; + if CD1.Execute then + Control.Dis_ColorShadow := CD1.Color; + end; + 0: + begin + CD1.Color := Control.Def_ColorShadow; + if CD1.Execute then + Control.All_ColorShadow := CD1.Color; + end; + end; + if StatesList.CurIndex <> 0 then + Col6.Color := CD1.Color; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.StatesListSelChange(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Col1.Color := Control.Def_ColorOuter; + Col2.Color := Control.Def_ColorFrom; + Col3.Color := Control.Def_ColorTo; + Col4.Color := Control.Def_BorderColor; + Col5.Color := Control.Def_ColorText; + Col6.Color := Control.Def_ColorShadow; + GradStyles.CurIndex := Integer(Control.Def_GradientStyle); + BorderWidth.Text := int2str(Control.Def_BorderWidth); + ShadowOffset.Text := int2str(Control.Def_ShadowOffset); + BorderWi.Text := int2str(Control.Def_BorderRoundWidth); + BorderHe.Text := int2str(Control.Def_BorderRoundHeight); + GlyphX.Text := int2str(Control.Def_GlyphItemX); + GlyphY.Text := int2str(Control.Def_GlyphItemY); + end; + 2: + begin + Col1.Color := Control.Over_ColorOuter; + Col2.Color := Control.Over_ColorFrom; + Col3.Color := Control.Over_ColorTo; + Col4.Color := Control.Over_BorderColor; + Col5.Color := Control.Over_ColorText; + Col6.Color := Control.Over_ColorShadow; + GradStyles.CurIndex := Integer(Control.Over_GradientStyle); + BorderWidth.Text := int2str(Control.Over_BorderWidth); + ShadowOffset.Text := int2str(Control.Over_ShadowOffset); + BorderWi.Text := int2str(Control.Over_BorderRoundWidth); + BorderHe.Text := int2str(Control.Over_BorderRoundHeight); + GlyphX.Text := int2str(Control.Over_GlyphItemX); + GlyphY.Text := int2str(Control.Over_GlyphItemY); + end; + 3: + begin + Col1.Color := Control.Down_ColorOuter; + Col2.Color := Control.Down_ColorFrom; + Col3.Color := Control.Down_ColorTo; + Col4.Color := Control.Down_BorderColor; + Col5.Color := Control.Down_ColorText; + Col6.Color := Control.Down_ColorShadow; + GradStyles.CurIndex := Integer(Control.Down_GradientStyle); + BorderWidth.Text := int2str(Control.Down_BorderWidth); + ShadowOffset.Text := int2str(Control.Down_ShadowOffset); + BorderWi.Text := int2str(Control.Down_BorderRoundWidth); + BorderHe.Text := int2str(Control.Down_BorderRoundHeight); + GlyphX.Text := int2str(Control.Down_GlyphItemX); + GlyphY.Text := int2str(Control.Down_GlyphItemY); + end; + 4: + begin + Col1.Color := Control.Dis_ColorOuter; + Col2.Color := Control.Dis_ColorFrom; + Col3.Color := Control.Dis_ColorTo; + Col4.Color := Control.Dis_BorderColor; + Col5.Color := Control.Dis_ColorText; + Col6.Color := Control.Dis_ColorShadow; + GradStyles.CurIndex := Integer(Control.Dis_GradientStyle); + BorderWidth.Text := int2str(Control.Dis_BorderWidth); + ShadowOffset.Text := int2str(Control.Dis_ShadowOffset); + BorderWi.Text := int2str(Control.Dis_BorderRoundWidth); + BorderHe.Text := int2str(Control.Dis_BorderRoundHeight); + GlyphX.Text := int2str(Control.Dis_GlyphItemX); + GlyphY.Text := int2str(Control.Dis_GlyphItemY); + end; + 0: + begin + Col1.Color := clLtGray; + Col2.Color := clLtGray; + Col3.Color := clLtGray; + Col4.Color := clLtGray; + Col5.Color := clLtGray; + Col6.Color := clLtGray; + GradStyles.CurIndex := 0; + BorderWidth.Text := '0'; + ShadowOffset.Text := '0'; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + GlyphX.Text := '0'; + GlyphY.Text := '0'; + end; + end; +end; + +procedure TSplitterEditor.UpdateSpeedSelChange(Sender: PObj); +begin + Control.All_UpdateSpeed := TGRushSpeed(UpdateSpeed.CurIndex); +end; + +procedure TSplitterEditor.AntiAliasingClick(Sender: PObj); +begin + Control.All_AntiAliasing := AntiAliasing.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.DrawGlyphClick(Sender: PObj); +begin + Control.All_DrawGlyph := DrawGlyph.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.DrawTextClick(Sender: PObj); +begin + Control.All_DrawText := DrawText.Checked; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.CaptionChange(Sender: PObj); +begin + Control.Caption := Caption.Text; +end; + +procedure TSplitterEditor.GlyphHorzSelChange(Sender: PObj); +begin + Control.All_GlyphHAlign := TGRushHAlign(GlyphHorz.CurIndex); + Control.Invalidate; +end; + +procedure TSplitterEditor.GlyphVertSelChange(Sender: PObj); +begin + Control.All_GlyphVAlign := TVerticalAlign(GlyphVert.CurIndex); + Control.Invalidate; +end; + +procedure TSplitterEditor.TextHorzSelChange(Sender: PObj); +begin + Control.All_TextHAlign := TGRushHAlign(TextHorz.CurIndex); + Control.Invalidate; +end; + +procedure TSplitterEditor.TextVertSelChange(Sender: PObj); +begin + Control.All_TextVAlign := TVerticalAlign(TextVert.CurIndex); + Control.Invalidate; +end; + +procedure TSplitterEditor.Col1Paint(Sender: PControl; DC: HDC); +var TR: TRect; + BR: HBRUSH; +begin + Rectangle(DC, 0, 0, Sender.Width, Sender.Height); + TR := MakeRect(1, 1, Sender.Width - 1, Sender.Height - 1); + BR := CreateSolidBrush(Color2RGB(Sender.Color)); + FillRect(DC, TR, BR); + DeleteObject(BR); +end; + +procedure TSplitterEditor.CheckEnabledRecalcRects(Sender: PGRushControl; + var Rects: TGrushRects); +begin + OffsetRect(Rects.DownBorderRect, 1, 1); +end; + +procedure TSplitterEditor.BorderWiEnter(Sender: PObj); +begin + Sender.Tag := DWORD(str2int(PControl(Sender).Text)); +end; + +procedure TSplitterEditor.BorderWiLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := Val; + end; + 2: + begin + Control.Over_BorderRoundWidth := Val; + end; + 3: + begin + Control.Down_BorderRoundWidth := Val; + end; + 4: + begin + Control.Dis_BorderRoundWidth := Val; + end; + 0: + begin + Control.All_BorderRoundWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.BorderHeLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundHeight := Val; + end; + 2: + begin + Control.Over_BorderRoundHeight := Val; + end; + 3: + begin + Control.Down_BorderRoundHeight := Val; + end; + 4: + begin + Control.Dis_BorderRoundHeight := Val; + end; + 0: + begin + Control.All_BorderRoundHeight := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.GlyphXLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := Val; + end; + 2: + begin + Control.Over_GlyphItemX := Val; + end; + 3: + begin + Control.Down_GlyphItemX := Val; + end; + 4: + begin + Control.Dis_GlyphItemX := Val; + end; + 0: + begin + Control.All_GlyphItemX := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.GlyphYLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemY := Val; + end; + 2: + begin + Control.Over_GlyphItemY := Val; + end; + 3: + begin + Control.Down_GlyphItemY := Val; + end; + 4: + begin + Control.Dis_GlyphItemY := Val; + end; + 0: + begin + Control.All_GlyphItemY := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.GlyphWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphWidth := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.GlyphHeightLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_GlyphHeight := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.SpacingLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_Spacing := Val; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.LLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Left := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.TLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Top := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.RLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Right := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.BLeave(Sender: PObj); +var TR: TRect; + Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + TR := Control.All_ContentOffsets; + TR.Bottom := Val; + Control.All_ContentOffsets := TR; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.ShadowOffsetLeave(Sender: PObj); +var Val: integer; +begin + Val := str2int(PControl(Sender).Text); + if Val = Integer(Sender.tag) then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := Val; + end; + 2: + begin + Control.Over_ShadowOffset := Val; + end; + 3: + begin + Control.Down_ShadowOffset := Val; + end; + 4: + begin + Control.Dis_ShadowOffset := Val; + end; + 0: + begin + Control.All_ShadowOffset := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.BorderWidthLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := Val; + end; + 2: + begin + Control.Over_BorderWidth := Val; + end; + 3: + begin + Control.Down_BorderWidth := Val; + end; + 4: + begin + Control.Dis_BorderWidth := Val; + end; + 0: + begin + Control.All_BorderWidth := Val; + PControl(Sender).Text := '0'; + end; + end; + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton11Click(Sender: PObj); +begin + GlyphHorz.CurIndex := 0; + Control.All_GlyphHAlign := haLeft; + GlyphVert.CurIndex := 1; + Control.All_GlyphVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton12Click(Sender: PObj); +begin + TextHorz.CurIndex := 1; + Control.All_TextHAlign := haCenter; + TextVert.CurIndex := 1; + Control.All_TextVAlign := vaCenter; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton16Click(Sender: PObj); +begin + L.Text := '4'; + T.Text := '4'; + R.Text := '-4'; + B.Text := '-4'; + Control.All_ContentOffsets := MakeRect(4, 4, -4, -4); + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton17Click(Sender: PObj); +begin + Spacing.Text := '5'; + Control.All_Spacing := 5; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton19Click(Sender: PObj); +begin + UpdateSpeed.CurIndex := 2; + Control.All_UpdateSpeed := usVeryFast; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton13Click(Sender: PObj); +begin + GlyphWidth.Text := '0'; + Control.All_GlyphWidth := 0; + GlyphHeight.Text := '0'; + Control.All_GlyphHeight := 0; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton10Click(Sender: PObj); +begin + GlyphX.Text := '0'; + GlyphY.Text := '0'; + case StatesList.CurIndex of + 1: + begin + Control.Def_GlyphItemX := 0; + Control.Def_GlyphItemY := 0; + end; + 2: + begin + Control.Over_GlyphItemX := 0; + Control.Over_GlyphItemY := 0; + end; + 3: + begin + Control.Down_GlyphItemX := 0; + Control.Down_GlyphItemY := 0; + end; + 4: + begin + Control.Dis_GlyphItemX := 0; + Control.Dis_GlyphItemY := 0; + end; + 0: + begin + Control.All_GlyphItemX := 0; + Control.All_GlyphItemY := 0; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushPanel3MouseDown(Sender: PControl; + var Mouse: TMouseEventData); +begin + CD1.Color := GRushPanel3.Def_ColorFrom; + if CD1.Execute then begin + GRushPanel3.Def_ColorFrom := CD1.Color; + CheckEnabled.All_ColorOuter := CD1.Color; + CheckTransparent.All_ColorOuter := CD1.Color; + GRushPanel3.InvalidateEx; + end; +end; + +procedure TSplitterEditor.GRushButton9Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderRoundWidth := 0; + Control.Def_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 2: + begin + Control.Over_BorderRoundWidth := 0; + Control.Over_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 3: + begin + Control.Down_BorderRoundWidth := 0; + Control.Down_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 4: + begin + Control.Dis_BorderRoundWidth := 0; + Control.Dis_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + 0: + begin + Control.All_BorderRoundWidth := 0; + Control.All_BorderRoundHeight := 0; + BorderWi.Text := '0'; + BorderHe.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton8Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 2: + begin + Control.Over_ShadowOffset := 1; + ShadowOffset.Text := '1'; + end; + 3: + begin + Control.Down_ShadowOffset := -1; + ShadowOffset.Text := '-1'; + end; + 4: + begin + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '2'; + end; + 0: + begin + Control.Def_ShadowOffset := 1; + Control.Over_ShadowOffset := 1; + Control.Down_ShadowOffset := -1; + Control.Dis_ShadowOffset := 2; + ShadowOffset.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton7Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderWidth := 0; + BorderWidth.Text := '0'; + end; + 2: + begin + Control.Over_BorderWidth := 0; + BorderWidth.Text := '0'; + end; + 3: + begin + Control.Down_BorderWidth := 0; + BorderWidth.Text := '0'; + end; + 4: + begin + Control.Dis_BorderWidth := 0; + BorderWidth.Text := '0'; + end; + 0: + begin + Control.Def_BorderWidth := 0; + Control.Over_BorderWidth := 0; + Control.Down_BorderWidth := 0; + Control.Dis_BorderWidth := 0; + BorderWidth.Text := '0'; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton18Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_GradientStyle := gsSolid; + GradStyles.CurIndex := 0; + end; + 2: + begin + if Control.Align in [caLeft, caRight] then begin + Control.Over_GradientStyle := gsHorizontal; + GradStyles.CurIndex := 2; + end else begin + Control.Over_GradientStyle := gsVertical; + GradStyles.CurIndex := 3; + end; + end; + 3: + begin + if Control.Align in [caLeft, caRight] then begin + Control.Down_GradientStyle := gsHorizontal; + GradStyles.CurIndex := 2; + end else begin + Control.Down_GradientStyle := gsVertical; + GradStyles.CurIndex := 3; + end; + end; + 4: + begin + if Control.Align in [caLeft, caRight] then begin + Control.Dis_GradientStyle := gsHorizontal; + GradStyles.CurIndex := 2; + end else begin + Control.Dis_GradientStyle := gsVertical; + GradStyles.CurIndex := 3; + end; + end; + 0: + begin + if Control.Align in [caLeft, caRight] then begin + Control.All_GradientStyle := gsHorizontal; + end else begin + Control.All_GradientStyle := gsVertical; + end; + Control.Def_GradientStyle := gsSolid; + GradStyles.CurIndex := 0; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton1Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 2: + begin + Control.Over_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 3: + begin + Control.Down_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 4: + begin + Control.Dis_ColorOuter := clBtnFace; + Col1.Color := clBtnFace; + end; + 0: + begin + Control.All_ColorOuter := clBtnFace; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton2Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorFrom := clBtnFace; + Col2.Color := clBtnFace; + end; + 2: + begin + Control.Over_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 3: + begin + Control.Down_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 4: + begin + Control.Dis_ColorFrom := clWhite; + Col2.Color := clWhite; + end; + 0: + begin + Control.Def_ColorFrom := clBtnFace; + Control.Over_ColorFrom := clWhite; + Control.Down_ColorFrom := clWhite; + Control.Dis_ColorFrom := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton3Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorTo := $00D1BEAF; + Col3.Color := $00D1BEAF; + end; + 2: + begin + Control.Over_ColorTo := $D0AD95; + Col3.Color := $D0AD95; + end; + 3: + begin + Control.Down_ColorTo := $C39475; + Col3.Color := $C39475; + end; + 4: + begin + Control.Dis_ColorTo := $009EACB4; + Col3.Color := $009EACB4; + end; + 0: + begin + Control.Def_ColorTo := $00D1BEAF; + Control.Over_ColorTo := $D0AD95; + Control.Down_ColorTo := $C39475; + Control.Dis_ColorTo := $009EACB4; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton4Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 2: + begin + Control.Over_BorderColor := $00A4A0A0; + Col4.Color := $00A4A0A0; + end; + 3: + begin + Control.Down_BorderColor := clGray; + Col4.Color := clGray; + end; + 4: + begin + Control.Dis_BorderColor := clGray; + Col4.Color := clGray; + end; + 0: + begin + Control.Def_BorderColor := $00A4A0A0; + Control.Over_BorderColor := $00A4A0A0; + Control.Down_BorderColor := clGray; + Control.Dis_BorderColor := clGray; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton5Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorText := clBlack; + Col5.Color := clBlack; + end; + 2: + begin + Control.Over_ColorText := clBlack; + Col5.Color := clBlack; + end; + 3: + begin + Control.Down_ColorText := clBlack; + Col5.Color := clBlack; + end; + 4: + begin + Control.Dis_ColorText := clBlack; + Col5.Color := clBlack; + end; + 0: + begin + Control.All_ColorText := clBlack; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton6Click(Sender: PObj); +begin + case StatesList.CurIndex of + 1: + begin + Control.Def_ColorShadow := clWhite; + Col5.Color := clWhite; + end; + 2: + begin + Control.Over_ColorShadow := clGray; + Col5.Color := clGray; + end; + 3: + begin + Control.Down_ColorShadow := clGray; + Col5.Color := clGray; + end; + 4: + begin + Control.Dis_ColorShadow := clGray; + Col5.Color := clGray; + end; + 0: + begin + Control.All_ColorShadow := clGray; + Control.Def_ColorShadow := clWhite; + end; + end; + Control.Invalidate; +end; + +procedure TSplitterEditor.GRushButton14Click(Sender: PObj); +begin + GRushButton1Click(GRushButton1); + GRushButton2Click(GRushButton2); + GRushButton3Click(GRushButton3); + GRushButton4Click(GRushButton4); + GRushButton5Click(GRushButton5); + GRushButton6Click(GRushButton6); + GRushButton18Click(GRushButton18); + GRushButton7Click(GRushButton7); + GRushButton8Click(GRushButton8); + GRushButton9Click(GRushButton9); + GRushButton10Click(GRushButton10); +end; + +procedure TSplitterEditor.GRushButton20Click(Sender: PObj); +begin + StatesList.CurIndex := 0; + GRushButton14Click(GRushButton14); + GRushButton11Click(GRushButton11); + GRushButton12Click(GRushButton12); + GRushButton13Click(GRushButton13); + GRushButton16Click(GRushButton16); + GRushButton17Click(GRushButton17); + GRushButton19Click(GRushButton19); + Control.All_AntiAliasing := TRUE; + Control.All_DrawFocusRect := FALSE; + Control.All_CropTopFirst := TRUE; + Control.All_GlyphAttached := FALSE; + Control.All_DrawGlyph := TRUE; + Control.All_DrawText := TRUE; + KOLForm1FormCreate(SplitterEditor); + Control.Invalidate; +end; + +procedure TSplitterEditor.KOLForm1Close(Sender: PObj; var Accept: Boolean); +begin + Accept := TRUE; + + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + TerminateExecution(KOL.Applet); +end; + +procedure TSplitterEditor.GRushButton15Click(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + if Component.Align in [mirror.caLeft, mirror.caRight] then begin + TControlAlign((@Control.Align)^) := caLeft; + Control.Cursor := LoadCursor(0, IDC_SIZEWE); + end; + + Data.fPSDef.ColorFrom := Styles.DefPaintState.ColorFrom; + Data.fPSDef.ColorTo := Styles.DefPaintState.ColorTo; + Data.fPSDef.ColorOuter := Styles.DefPaintState.ColorOuter; + Data.fPSDef.ColorText := Styles.DefPaintState.ColorText; + Data.fPSDef.ColorShadow := Styles.DefPaintState.ColorShadow; + Data.fPSDef.BorderColor := Styles.DefPaintState.BorderColor; + Data.fPSDef.BorderRoundWidth := Styles.DefPaintState.BorderRoundWidth; + Data.fPSDef.BorderRoundHeight := Styles.DefPaintState.BorderRoundHeight; + Data.fPSDef.BorderWidth := Styles.DefPaintState.BorderWidth; + Data.fPSDef.GradientStyle := Styles.DefPaintState.GradientStyle; + Data.fPSDef.ShadowOffset := Styles.DefPaintState.ShadowOffset; + Data.fPSDef.GlyphItemX := Styles.DefPaintState.GlyphItemX; + Data.fPSDef.GlyphItemY := Styles.DefPaintState.GlyphItemY; + + Data.fPSOver.ColorFrom := Styles.OverPaintState.ColorFrom; + Data.fPSOver.ColorTo := Styles.OverPaintState.ColorTo; + Data.fPSOver.ColorOuter := Styles.OverPaintState.ColorOuter; + Data.fPSOver.ColorText := Styles.OverPaintState.ColorText; + Data.fPSOver.ColorShadow := Styles.OverPaintState.ColorShadow; + Data.fPSOver.BorderColor := Styles.OverPaintState.BorderColor; + Data.fPSOver.BorderRoundWidth := Styles.OverPaintState.BorderRoundWidth; + Data.fPSOver.BorderRoundHeight := Styles.OverPaintState.BorderRoundHeight; + Data.fPSOver.BorderWidth := Styles.OverPaintState.BorderWidth; + Data.fPSOver.GradientStyle := Styles.OverPaintState.GradientStyle; + Data.fPSOver.ShadowOffset := Styles.OverPaintState.ShadowOffset; + Data.fPSOver.GlyphItemX := Styles.OverPaintState.GlyphItemX; + Data.fPSOver.GlyphItemY := Styles.OverPaintState.GlyphItemY; + + Data.fPSDown.ColorFrom := Styles.DownPaintState.ColorFrom; + Data.fPSDown.ColorTo := Styles.DownPaintState.ColorTo; + Data.fPSDown.ColorOuter := Styles.DownPaintState.ColorOuter; + Data.fPSDown.ColorText := Styles.DownPaintState.ColorText; + Data.fPSDown.ColorShadow := Styles.DownPaintState.ColorShadow; + Data.fPSDown.BorderColor := Styles.DownPaintState.BorderColor; + Data.fPSDown.BorderRoundWidth := Styles.DownPaintState.BorderRoundWidth; + Data.fPSDown.BorderRoundHeight := Styles.DownPaintState.BorderRoundHeight; + Data.fPSDown.BorderWidth := Styles.DownPaintState.BorderWidth; + Data.fPSDown.GradientStyle := Styles.DownPaintState.GradientStyle; + Data.fPSDown.ShadowOffset := Styles.DownPaintState.ShadowOffset; + Data.fPSDown.GlyphItemX := Styles.DownPaintState.GlyphItemX; + Data.fPSDown.GlyphItemY := Styles.DownPaintState.GlyphItemY; + + Data.fPSDis.ColorFrom := Styles.DisPaintState.ColorFrom; + Data.fPSDis.ColorTo := Styles.DisPaintState.ColorTo; + Data.fPSDis.ColorOuter := Styles.DisPaintState.ColorOuter; + Data.fPSDis.ColorText := Styles.DisPaintState.ColorText; + Data.fPSDis.ColorShadow := Styles.DisPaintState.ColorShadow; + Data.fPSDis.BorderColor := Styles.DisPaintState.BorderColor; + Data.fPSDis.BorderRoundWidth := Styles.DisPaintState.BorderRoundWidth; + Data.fPSDis.BorderRoundHeight := Styles.DisPaintState.BorderRoundHeight; + Data.fPSDis.BorderWidth := Styles.DisPaintState.BorderWidth; + Data.fPSDis.GradientStyle := Styles.DisPaintState.GradientStyle; + Data.fPSDis.ShadowOffset := Styles.DisPaintState.ShadowOffset; + Data.fPSDis.GlyphItemX := Styles.DisPaintState.GlyphItemX; + Data.fPSDis.GlyphItemY := Styles.DisPaintState.GlyphItemY; + + Data.fContentOffsets.Left := Styles.ContentOffsets.Left; + Data.fContentOffsets.Top := Styles.ContentOffsets.Top; + Data.fContentOffsets.Right := Styles.ContentOffsets.Right; + Data.fContentOffsets.Bottom := Styles.ContentOffsets.Bottom; + + if Styles.GlyphWidth <> 0 then + Data.fGlyphWidth := Styles.GlyphWidth + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemWidth <> 0) then + Data.fGlyphWidth := Component.imagecollection.ItemWidth; + if Styles.GlyphHeight <> 0 then + Data.fGlyphHeight := Styles.GlyphHeight + else if Assigned(Component.imagecollection) then + if (Component.imagecollection.ItemHeight <> 0) then + Data.fGlyphHeight := Component.imagecollection.ItemHeight; + + Data.fSplitterDotsCount := Styles.SplitterDotsCount; + Data.fCheckMetric := 0;//Styles.CheckMetric; + Data.fColorCheck := 0;//Styles.ColorCheck; + Data.fGlyphVAlign := Styles.GlyphVAlign; + Data.fGlyphHAlign := Styles.GlyphHAlign; + Data.fTextVAlign := Styles.TextVAlign; + Data.fTextHAlign := Styles.TextHAlign; + Data.fDrawGlyph := Styles.DrawGlyph; + Data.fDrawText := Styles.DrawText; + Data.fDrawFocusRect := FALSE;//Styles.DrawFocusRect; + Data.fDrawProgress := FALSE;//Styles.DrawProgress; + Data.fDrawProgressRect := FALSE;//Styles.DrawProgressRect; + Data.fGlyphAttached := FALSE;//Styles.GlyphAttached; + Data.fCropTopFirst := TRUE;//Styles.CropTopFirst; + Data.fAntiAliasing := Styles.AntiAliasing; + Data.fProgressVertical := FALSE;//Styles.ProgressVertical; + Data.fUpdateSpeed := Styles.UpdateSpeed; + Data.fSpacing := Styles.Spacing; + + KOLForm1FormCreate(SplitterEditor); + + Control.SetAllNeedUpdate; + Control.Invalidate; +end; + +procedure TSplitterEditor.ButtonOKClick(Sender: PObj); +var Data: PGRushData; +begin + Data := PGRushData(Control.CustomObj); + + Styles.DefPaintState.ColorFrom := Data.fPSDef.ColorFrom; + Styles.DefPaintState.ColorTo := Data.fPSDef.ColorTo; + Styles.DefPaintState.ColorOuter := Data.fPSDef.ColorOuter; + Styles.DefPaintState.ColorText := Data.fPSDef.ColorText; + Styles.DefPaintState.ColorShadow := Data.fPSDef.ColorShadow; + Styles.DefPaintState.BorderColor := Data.fPSDef.BorderColor; + Styles.DefPaintState.BorderRoundWidth := Data.fPSDef.BorderRoundWidth; + Styles.DefPaintState.BorderRoundHeight := Data.fPSDef.BorderRoundHeight; + Styles.DefPaintState.BorderWidth := Data.fPSDef.BorderWidth; + Styles.DefPaintState.GradientStyle := Data.fPSDef.GradientStyle; + Styles.DefPaintState.ShadowOffset := Data.fPSDef.ShadowOffset; + Styles.DefPaintState.GlyphItemX := Data.fPSDef.GlyphItemX; + Styles.DefPaintState.GlyphItemY := Data.fPSDef.GlyphItemY; + + Styles.OverPaintState.ColorFrom := Data.fPSOver.ColorFrom; + Styles.OverPaintState.ColorTo := Data.fPSOver.ColorTo; + Styles.OverPaintState.ColorOuter := Data.fPSOver.ColorOuter; + Styles.OverPaintState.ColorText := Data.fPSOver.ColorText; + Styles.OverPaintState.ColorShadow := Data.fPSOver.ColorShadow; + Styles.OverPaintState.BorderColor := Data.fPSOver.BorderColor; + Styles.OverPaintState.BorderRoundWidth := Data.fPSOver.BorderRoundWidth; + Styles.OverPaintState.BorderRoundHeight := Data.fPSOver.BorderRoundHeight; + Styles.OverPaintState.BorderWidth := Data.fPSOver.BorderWidth; + Styles.OverPaintState.GradientStyle := Data.fPSOver.GradientStyle; + Styles.OverPaintState.ShadowOffset := Data.fPSOver.ShadowOffset; + Styles.OverPaintState.GlyphItemX := Data.fPSOver.GlyphItemX; + Styles.OverPaintState.GlyphItemY := Data.fPSOver.GlyphItemY; + + Styles.DownPaintState.ColorFrom := Data.fPSDown.ColorFrom; + Styles.DownPaintState.ColorTo := Data.fPSDown.ColorTo; + Styles.DownPaintState.ColorOuter := Data.fPSDown.ColorOuter; + Styles.DownPaintState.ColorText := Data.fPSDown.ColorText; + Styles.DownPaintState.ColorShadow := Data.fPSDown.ColorShadow; + Styles.DownPaintState.BorderColor := Data.fPSDown.BorderColor; + Styles.DownPaintState.BorderRoundWidth := Data.fPSDown.BorderRoundWidth; + Styles.DownPaintState.BorderRoundHeight := Data.fPSDown.BorderRoundHeight; + Styles.DownPaintState.BorderWidth := Data.fPSDown.BorderWidth; + Styles.DownPaintState.GradientStyle := Data.fPSDown.GradientStyle; + Styles.DownPaintState.ShadowOffset := Data.fPSDown.ShadowOffset; + Styles.DownPaintState.GlyphItemX := Data.fPSDown.GlyphItemX; + Styles.DownPaintState.GlyphItemY := Data.fPSDown.GlyphItemY; + + Styles.DisPaintState.ColorFrom := Data.fPSDis.ColorFrom; + Styles.DisPaintState.ColorTo := Data.fPSDis.ColorTo; + Styles.DisPaintState.ColorOuter := Data.fPSDis.ColorOuter; + Styles.DisPaintState.ColorText := Data.fPSDis.ColorText; + Styles.DisPaintState.ColorShadow := Data.fPSDis.ColorShadow; + Styles.DisPaintState.BorderColor := Data.fPSDis.BorderColor; + Styles.DisPaintState.BorderRoundWidth := Data.fPSDis.BorderRoundWidth; + Styles.DisPaintState.BorderRoundHeight := Data.fPSDis.BorderRoundHeight; + Styles.DisPaintState.BorderWidth := Data.fPSDis.BorderWidth; + Styles.DisPaintState.GradientStyle := Data.fPSDis.GradientStyle; + Styles.DisPaintState.ShadowOffset := Data.fPSDis.ShadowOffset; + Styles.DisPaintState.GlyphItemX := Data.fPSDis.GlyphItemX; + Styles.DisPaintState.GlyphItemY := Data.fPSDis.GlyphItemY; + + Styles.ContentOffsets.Left := Data.fContentOffsets.Left; + Styles.ContentOffsets.Top := Data.fContentOffsets.Top; + Styles.ContentOffsets.Right := Data.fContentOffsets.Right; + Styles.ContentOffsets.Bottom := Data.fContentOffsets.Bottom; + + Styles.GlyphWidth := Data.fGlyphWidth; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemWidth = Data.fGlyphWidth then + Styles.GlyphWidth := 0; + if (Component.imagecollection.ItemWidth = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Width) = Data.fGlyphWidth) then + Styles.GlyphWidth := 0; + end; + Styles.GlyphHeight := Data.fGlyphHeight; + if Assigned(Component.imagecollection) then begin + if Component.imagecollection.ItemHeight = Data.fGlyphHeight then + Styles.GlyphHeight := 0; + if (Component.imagecollection.ItemHeight = 0) and Assigned(Data.fGlyphBitmap) then + if (DWORD(Data.fGlyphBitmap.Height) = Data.fGlyphHeight) then + Styles.GlyphHeight := 0; + end; + + Styles.GlyphVAlign := Data.fGlyphVAlign; + Styles.GlyphHAlign := Data.fGlyphHAlign; + Styles.TextVAlign := Data.fTextVAlign; + Styles.TextHAlign := Data.fTextHAlign; + Styles.DrawGlyph := Data.fDrawGlyph; + Styles.DrawText := Data.fDrawText; + Styles.GlyphAttached := FALSE;//Data.fGlyphAttached; + Styles.CropTopFirst := TRUE;//Data.fCropTopFirst; + Styles.AntiAliasing := Data.fAntiAliasing; + Styles.UpdateSpeed := Data.fUpdateSpeed; + Styles.Spacing := Data.fSpacing; + Styles.SplitterDotsCount := Data.fSplitterDotsCount; + + Prop.SetOrdValue( Integer(Styles) ); + Form.Close; +end; + +procedure TSplitterEditor.ButtonCancelClick(Sender: PObj); +begin + Form.Close; +end; + +procedure TSplitterEditor.CropTopFirstClick(Sender: PObj); +begin +end; + +procedure TSplitterEditor.GlyphAttachedClick(Sender: PObj); +begin +end; + +procedure TSplitterEditor.WordWrapClick(Sender: PObj); +begin +end; + +procedure TSplitterEditor.GRushButton21Click(Sender: PObj); +begin + DotsCount.Text := '16'; + Control.All_SplitterDotsCount := 16; + Control.Invalidate; +end; + +procedure TSplitterEditor.DotsCountLeave(Sender: PObj); +var Val: DWORD; +begin + Val := str2int(PControl(Sender).Text); + if Val = Sender.tag then exit; + Control.All_SplitterDotsCount := Val; + Control.Invalidate; +end; + + + + + + +function TSplitterStylesProp.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paSubProperties, paDialog, paReadOnly]; +end; + +procedure TSplitterStylesProp.Edit; +var Styles: TKOLGRushSplitterStyles; +begin + Styles := TKOLGRushSplitterStyles(GetOrdValue); + if Styles = nil then exit; + if not (Styles is TKOLGRushSplitterStyles) then exit; + + SplitterEditor := nil; + AppletTerminated := FALSE; + try + NewSplitterEditor(SplitterEditor, Self); + SplitterEditor.ActiveWindow := GetActiveWindow; + SplitterEditor.WindowList := DisableTaskWindows(0); + KOL.Run(KOL.Applet); + finally + end; +end; + + +end. + diff --git a/Addons/err.pas b/Addons/err.pas new file mode 100644 index 0000000..947bc10 --- /dev/null +++ b/Addons/err.pas @@ -0,0 +1,1197 @@ +{$DEFINE ASM_VERSION} +//{$DEFINE VARIANT_USED} + +{$IFDEF ASM_VERSION} + {$IFDEF PAS_VERSION} + {$UNDEF ASM_VERSION} + {$ENDIF} +{$ENDIF} + +{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + KKKKK KKKKK OOOOOOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKKKKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOO OOOOO LLLLL + KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL + KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL + + Key Objects Library (C) 2000 by Kladov Vladimir. + + mailto: bonanzas@xcl.cjb.net + Home: http://kol.nm.ru + http://xcl.cjb.net + http://xcl.nm.ru + + =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} +{ + This code is grabbed mainly from standard SysUtils.pas unit, + provided by Borland Delphi. This unit is for handling exceptions, + and to use it just place a reference to exceptions unit in + uses clause of any of your unit or dpr-file. +} + +{ Copyright (C) 1995,99 Inprise Corporation } +{ Copyright (C) 2001, Kladov Vladimir } + +unit err; +{* Unit to provide error handling for KOL programs using efficient + exceptions mechanism. To use it, just place a reference to it into + uses clause of any unit of the project (or dpr-file). + |

+ It is possible to use standard SysUtils instead, but it increases + size of executable at least by 10K. Using this unit to handle exceptions + increases executable only by 6,5K. +} + +interface + +uses Windows, KOL; + +{$I KOLDEF.INC} +{$IFDEF _D6orHigher} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} +{$IFDEF _D7orHigher} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{+} // These resource strings are grabbed from SysConst and changed a bit to make it smaller. + +//{$DEFINE USE_RESOURCESTRING} +{$IFDEF _D2orD3} + {$IFDEF USE_RESOURCESTRING} + {$UNDEF USE_RESOURCESTRING} + {$ENDIF} +{$ENDIF} + +{$IFDEF _D2orD3} +type + LongWord = DWORD; +{$ENDIF} +{$IFNDEF USE_RESOURCESTRING} +const +{$ELSE} +resourcestring +{$ENDIF} + SUnknown = ''; + //SInvalidInteger = '''%s'' is not a valid integer value'; + //SInvalidFloat = '''%s'' is not a valid floating point value'; + //SInvalidDate = '''%s'' is not a valid date'; + //SInvalidTime = '''%s'' is not a valid time'; + //SInvalidDateTime = '''%s'' is not a valid date and time'; + //STimeEncodeError = 'Invalid argument to time encode'; + //SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = //'Read beyond end of file'; + 'End of file'; + SDiskFull = 'Disk full'; + //SInvalidInput = 'Invalid numeric input'; // {-} Seems for console input only + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; + SAccessViolation = 'Access violation at address %p. %s of address %p'; + SStackOverflow = 'Stack overflow'; + SControlC = //'Control-C hit'; + '^C'; // {-} for console applications only + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.'#10'%s%s'; + //SExceptTitle = 'Application Error'; + //SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + //SArgumentMissing = 'No argument for format ''%s'''; + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SDispatchError = 'Variant method calls not supported'; + SVarArrayCreate = 'Error creating variant array'; + SVarNotArray = 'Variant is not an array'; + SVarArrayBounds = 'Variant array index out of bounds'; + SVar = 'EVariant'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + //SResultTooLong = 'Format result longer than 4096 characters'; + //SFormatTooLong = 'Format string too long'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + {SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'#13#10'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + ';which is also contained in package ''%s''';} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s'; + SUnkWin32Error = 'A Win32 API function failed'; + SNL = 'Application is not licensed to use this feature'; +{-} + +type + +{ Generic procedure pointer } + + TProcedure = procedure; + +{ Generic filename type } + + TFileName = type string; + +{ Exceptions } + Exception = class; + TDestroyException = procedure( Sender: Exception ) of object; + + TError = ( e_Abort, e_Heap, e_OutOfMem, e_InOut, e_External, e_Int, + e_DivBy0, e_Range, e_IntOverflow, e_Math, e_Math_InvalidArgument, + e_InvalidOp, e_ZeroDivide, e_Overflow, e_Underflow, e_InvalidPointer, + e_InvalidCast, e_Convert, e_AccessViolation, e_Privilege, + e_StackOverflow, e_CtrlC, e_Variant, e_PropReadOnly, + e_PropWriteOnly, e_Assertion, e_Abstract, e_IntfCast, + e_InvalidContainer, e_InvalidInsert, e_Package, e_Win32, + e_SafeCall, e_License, e_Custom, e_Com, e_Ole, e_Registry ); + {* Main error codes. These are to determine which exception occure. You + can use e_Custom code for your own exceptions. } + + Exception = class(TObject) + {* Exception class. In KOL, there is a single exception class is used. + Instead of inheriting new exception classes from this ancestor, an + instance of the same Exception class should be used. The difference + is only in Code property, which contains a kind of exception. } + protected + FCode: TError; + FErrorCode: DWORD; + FMessage: string; + FExceptionRecord: PExceptionRecord; + FData: Pointer; + FOnDestroy: TDestroyException; + procedure SetData(const Value: Pointer); + public + constructor Create(ACode: TError; const Msg: string); + {* Use this constructor to raise exception, which does not require of + argument formatting. } + constructor CreateFmt(ACode: TError; const Msg: string; const Args: array of const); + {* Use this constructor to raise an exception with formatted Message string. + Take into attention, that Format procedure defined in KOL, uses API wvsprintf + function, which can understand a restricted set of format specifications. } + constructor CreateCustom(AError: DWORD; const Msg: String); + {* Use this constructor to create e_Custom exception and to assign AError to + its ErrorCode property. } + constructor CreateCustomFmt(AError: DWORD; const Msg: String; const Args: array of const); + {* Use this constructor to create e_Custom exception with formatted message + string and to assign AError to its ErrorCode property. } + constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const); + {* } + destructor Destroy; override; + {* destructor } + property Message: string read FMessage; // write FMessage; + {* Text string, containing descriptive message about the exception. } + property Code: TError read FCode; + {* Main exception code. This property can be used to determine, which exception + occure. } + property ErrorCode: DWORD read FErrorCode write FErrorCode; + {* This code is to detailize error. For Code = e_InOut, ErrorCode contains + more detail description of input/output error. For e_Custom, You can + assign it to any value You want. } + property ExceptionRecord: PExceptionRecord read FExceptionRecord; + {* This property is only for e_External exception. } + property Data: Pointer read FData write SetData; + {* Custom defined pointer. Use it in your custom exceptions. } + property OnDestroy: TDestroyException read FOnDestroy write FOnDestroy; + {* This event is to allow to do something when custom Exception is + released. } + end; + {* + With err unit, it is possible to use all capabilities of Delphi exception + handling almost in the same way as usual. The difference only in that the + single exception class should be used. To determine which exception occure, + use property Code. So, code to handle exception can be written like follow: + ! try + ! ... + ! except on E: Exception do + ! case E.Code of + ! e_DivBy0: HandleDivideByZero; + ! e_Overflow: HandleOverflow; + ! ... + ! end; + ! end; + To raise an error, create an instance of Exception class object, but + pass a Code to its constructor: + ! var E: Exception; + ! ... + ! E := Exception.Create( e_Custom, 'My custom exception' ); + ! E.ErrorCode := MY_MAGIC_CODE_FOR_CUSTOM_EXCEPTION; + ! raise E; + } + + ExceptClass = class of Exception; + +{ Exit procedure handling } + +{ AddExitProc adds the given procedure to the run-time library's exit + procedure list. When an application terminates, its exit procedures are + executed in reverse order of definition, i.e. the last procedure passed + to AddExitProc is the first one to get executed upon termination. } + +procedure AddExitProc(Proc: TProcedure); + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; + +{ Exception handling routines } + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PKOLChar; Size: Integer): Integer; + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + +procedure Abort; + +//procedure OutOfMemoryError; + +{ RaiseLastWin32Error calls the GetLastError API to retrieve the code for } +{ the last occuring Win32 error. If GetLastError returns an error code, } +{ RaiseLastWin32Error then raises an exception with the error code and } +{ message associated with with error. } + +procedure RaiseLastWin32Error; + +{ Win32Check is used to check the return value of a Win32 API function } +{ which returns a BOOL to indicate success. If the Win32 API function } +{ returns False (indicating failure), Win32Check calls RaiseLastWin32Error } +{ to raise an exception. If the Win32 API function returns True, } +{ Win32Check returns True. } + +function Win32Check(RetVal: BOOL): BOOL; + +{ Termination procedure support } + +type + TTerminateProc = function: Boolean; + +{ Call AddTerminateProc to add a terminate procedure to the system list of } +{ termination procedures. Delphi will call all of the function in the } +{ termination procedure list before an application terminates. The user- } +{ defined TermProc function should return True if the application can } +{ safely terminate or False if the application cannot safely terminate. } +{ If one of the functions in the termination procedure list returns False, } +{ the application will not terminate. } + +procedure AddTerminateProc(TermProc: TTerminateProc); + +{ CallTerminateProcs is called by VCL when an application is about to } +{ terminate. It returns True only if all of the functions in the } +{ system's terminate procedure list return True. This function is } +{ intended only to be called by Delphi, and it should not be called } +{ directly. } + +function CallTerminateProcs: Boolean; + +{$IFNDEF _D2} +function GDAL: LongWord; +procedure RCS; +procedure RPR; +{$ENDIF} + + +{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message + popup dialogs if the requested file can't be loaded. SafeLoadLibrary also + preserves the current FPU control word (precision, exception masks) across + the LoadLibrary call (in case the DLL you're loading hammers the FPU control + word in its initialization, as many MS DLLs do)} + +{$IFNDEF _D2orD3} +function SafeLoadLibrary(const Filename: KOLString; + ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; +{$ENDIF} + +implementation + +{procedure ConvertError(const Ident: string); +begin + raise Exception.Create(e_Convert, Ident); +end; + +procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const); +begin + raise Exception.CreateFmt(e_Convert, LoadResString(ResString), Args); +end;} + +{ Memory management routines } + +function AllocMem(Size: Cardinal): Pointer; +begin + GetMem(Result, Size); + FillChar(Result^, Size, 0); +end; + +{ Exit procedure handling } + +type + PExitProcInfo = ^TExitProcInfo; + TExitProcInfo = record + Next: PExitProcInfo; + SaveExit: Pointer; + Proc: TProcedure; + end; + +var + ExitProcList: PExitProcInfo = nil; + +procedure DoExitProc; +var + P: PExitProcInfo; + Proc: TProcedure; +begin + P := ExitProcList; + ExitProcList := P^.Next; + ExitProc := P^.SaveExit; + Proc := P^.Proc; + Dispose(P); + Proc; +end; + +procedure AddExitProc(Proc: TProcedure); +var + P: PExitProcInfo; +begin + New(P); + P^.Next := ExitProcList; + P^.SaveExit := ExitProc; + P^.Proc := Proc; + ExitProcList := P; + ExitProc := @DoExitProc; +end; + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; +var + Len: Integer; + Buffer: array[0..255] of KOLChar; +begin + Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or + FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, + SizeOf(Buffer), nil); + while (Len > 0) and ((Buffer[Len - 1] <= ' ') or + (Buffer[Len - 1] = '.')) do Dec(Len); + SetString(Result, Buffer, Len); +end; + +{ Exception handling routines } + +{var + OutOfMemory: EOutOfMemory; + InvalidPointer: EInvalidPointer;} + +type + PRaiseFrame = ^TRaiseFrame; + TRaiseFrame = record + NextRaise: PRaiseFrame; + ExceptAddr: Pointer; + ExceptObject: TObject; + ExceptionRecord: PExceptionRecord; + end; + +{ Return current exception object } + +function ExceptObject: TObject; +begin + if RaiseList <> nil then + Result := PRaiseFrame(RaiseList)^.ExceptObject else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseList <> nil then + Result := PRaiseFrame(RaiseList)^.ExceptAddr else + Result := nil; +end; + +{ Convert physical address to logical address } + +function ConvertAddr(Address: Pointer): Pointer; assembler; +asm + TEST EAX,EAX { Always convert nil to nil } + JE @@1 + SUB EAX, $1000 { offset from code start; code start set by linker to $1000 } +@@1: +end; + +{ Format and return an exception error message } + +{$IFDEF _D2} // this code is luck in D2 system.pas +{type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: Longint; + ResInstance: Longint; + Reserved: Integer; + end;} + +function FindResourceHInstance(Instance: Longint): Longint; +begin + Result := Instance; +end; +{$ENDIF} + +type + PStrData = ^TStrData; + TStrData = record + Ident: Integer; + Buffer: PKOLChar; + BufSize: Integer; + nChars: Integer; + end; + +function EnumStringModules(Instance: Longint; Data: Pointer): Boolean; +begin + with PStrData(Data)^ do + begin + nChars := LoadString(Instance, Ident, Buffer, BufSize); + Result := nChars = 0; + end; +end; + +{$IFNDEF _D2} +function FindStringResource(Ident: Integer; Buffer: PKOLChar; BufSize: Integer): Integer; +var + StrData: TStrData; +begin + StrData.Ident := Ident; + StrData.Buffer := Buffer; + StrData.BufSize := BufSize; + StrData.nChars := 0; + EnumResourceModules(EnumStringModules, @StrData); + Result := StrData.nChars; +end; +{$ENDIF} + +{$IFDEF _D2} +function LoadStr(Ident: Integer): string; +var + Buffer: array[0..1023] of Char; +begin + SetString(Result, Buffer, LoadString(HInstance, Ident, Buffer, + SizeOf(Buffer))); +end; +{$ELSE} +function LoadStr(Ident: Integer): string; +var + Buffer: array[0..1023] of KOLChar; +begin + SetString(Result, Buffer, FindStringResource(Ident, Buffer, SizeOf(Buffer))); +end; +{$ENDIF} + +function FmtLoadStr(Ident: Integer; const Args: array of const): string; +begin + //FmtStr(Result, LoadStr(Ident), Args); + Result := Format(LoadStr(Ident), Args); +end; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PKOLChar; Size: Integer): Integer; +var + MsgPtr: PChar; + //MsgEnd: PChar; + //MsgLen: Integer; + ModuleName: array[0..MAX_PATH] of KOLChar; + //Temp: array[0..MAX_PATH] of Char; + Fmt: array[0..255] of Char; + Info: TMemoryBasicInformation; + ConvertedAddress: Pointer; +begin + VirtualQuery(ExceptAddr, Info, sizeof(Info)); + if (Info.State <> MEM_COMMIT) or + (GetModuleFilename( THandle(Info.AllocationBase), {Temp} ModuleName, + SizeOf({Temp} ModuleName)) = 0) then + begin + GetModuleFileName(HInstance, {Temp} ModuleName, SizeOf({Temp} ModuleName)); + ConvertedAddress := ConvertAddr(ExceptAddr); + end + else + Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase); + //StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1); + {-} // Why to extract unit name from a path? Isn't it well to show complete path + // and to economy code for the extraction. + MsgPtr := ''; + //MsgEnd := ''; + if ExceptObject is Exception then + begin + MsgPtr := PChar(Exception(ExceptObject).Message); + //MsgLen := StrLen(MsgPtr); + //if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; + {-} // Isn't it too beautiful - devote ~40 bytes of code just to decide, + // add or not a point at the end of the message. + end; + {$IFNDEF USE_RESOURCESTRING} + StrCopy( Fmt, SException ); + {$ELSE} + LoadString(FindResourceHInstance(HInstance), + PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt)); + {$ENDIF} + //MsgOK( ModuleName ); + {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} + ( Buffer, PKOLChar( Format( Fmt, [ ExceptObject.ClassName, + ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) ); + Result := {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}(Buffer); +end; + +{ Display exception message box } + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); +var + Buffer: array[0..1023] of KOLChar; +begin + ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer)); + {if IsConsole then + WriteLn(Buffer) + else} + begin + {LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier, + Title, SizeOf(Title));} + MessageBox(0, Buffer, {Title} nil, MB_OK {or MB_ICONSTOP} or MB_SYSTEMMODAL); + end; +end; + +{ Raise abort exception } + +procedure Abort; + + function ReturnAddr: Pointer; + asm +// MOV EAX,[ESP + 4] !!! codegen dependant + MOV EAX,[EBP - 4] + end; + +begin + raise Exception.Create(e_Abort, SOperationAborted) at ReturnAddr; +end; + +{ Raise out of memory exception } + +{procedure OutOfMemoryError; +begin + raise OutOfMemory; +end;} + +{ Exception class } + +constructor Exception.CreateResFmt(ACode: TError; Ident: Integer; + const Args: array of const); +begin + FMessage := Format(LoadStr(Ident), Args); +end; + +destructor Exception.Destroy; +begin + if Assigned( FOnDestroy ) then + FOnDestroy( Self ); + inherited; +end; + +procedure Exception.SetData(const Value: Pointer); +begin + FData := Value; +end; + +constructor Exception.Create(ACode: TError; const Msg: string); +begin + FCode := ACode; + FMessage := Msg; + //FAllowFree := TRUE; +end; + +constructor Exception.CreateCustom(AError: DWORD; const Msg: String); +begin + FCode := e_Custom; + FMessage := Msg; + FErrorCode := AError; +end; + +constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: String; + const Args: array of const); +begin + FCode := e_Custom; + FErrorCode := AError; + FMessage := Format(Msg, Args); +end; + +constructor Exception.CreateFmt(ACode: TError; const Msg: string; + const Args: array of const); +begin + FCode := ACode; + FMessage := Format(Msg, Args); +end; + +{ EHeapException class } + +{procedure EHeapException.FreeInstance; +begin + if AllowFree then + inherited FreeInstance; +end;} + +{ Create I/O exception } + +function CreateInOutError: Exception; +type + TErrorRec = record + Code: Integer; + Ident: string; + end; +const + ErrorMap: array[0..5] of TErrorRec = ( + (Code: 2; Ident: SFileNotFound), + (Code: 3; Ident: SInvalidFilename), + (Code: 4; Ident: STooManyOpenFiles), + (Code: 5; Ident: SAccessDenied), + (Code: 100; Ident: SEndOfFile), + (Code: 101; Ident: SDiskFull){, + (Code: 106; Ident: SInvalidInput)} ); +var + I: Integer; + InOutRes: Integer; +begin + I := Low(ErrorMap); + InOutRes := IOResult; // resets IOResult to zero + while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I); + if I <= High(ErrorMap) then + Result := Exception.Create(e_InOut, ErrorMap[I].Ident) + else + Result := Exception.CreateFmt(e_InOut, SInOutError, [InOutRes]); + //Result := Exception.Create(e_InOut, SInOutError + Int2Str( InOutRes ) ); + Result.ErrorCode := InOutRes; +end; + +{ RTL error handler } + +type + TExceptMapRec = packed record + ECode: TError; + EIdent: String; + end; + +const + ExceptMap: array[1..24] of TExceptMapRec = ( + (ECode: e_OutOfMem; EIdent: SOutOfMemory), + (ECode: e_InvalidPointer; EIdent: SInvalidPointer), + (ECode: e_DivBy0; EIdent: SDivByZero), + (ECode: e_Range; EIdent: SRangeError), + (ECode: e_IntOverflow; EIdent: SIntOverflow), + (ECode: e_InvalidOp; EIdent: SInvalidOp), + (ECode: e_ZeroDivide; EIdent: SDivByZero), + (ECode: e_Overflow; EIdent: SOverflow), + (ECode: e_Underflow; EIdent: SUnderflow), + (ECode: e_InvalidCast; EIdent: SInvalidCast), + (ECode: e_AccessViolation;EIdent: SAccessViolation), + (ECode: e_Privilege; EIdent: SPrivilege), + (ECode: e_CtrlC; EIdent: SControlC), + // {-} Only for console applications + (ECode: e_StackOverflow; EIdent: SStackOverflow), + {$IFDEF VARIANT_USED} + (ECode: e_Variant; EIdent: SInvalidVarCast), + (ECode: e_Variant; EIdent: SInvalidVarOp), + (ECode: e_Variant; EIdent: SDispatchError), + (ECode: e_Variant; EIdent: SVarArrayCreate), + (ECode: e_Variant; EIdent: SVarNotArray), + (ECode: e_Variant; EIdent: SVarArrayBounds), + {$ELSE} + (ECode: e_Variant; EIdent: SVar), + (ECode: e_Variant; EIdent: SVar), + (ECode: e_Variant; EIdent: SVar), + (ECode: e_Variant; EIdent: SVar), + (ECode: e_Variant; EIdent: SVar), + (ECode: e_Variant; EIdent: SVar), + {$ENDIF} + (ECode: e_Assertion; EIdent: SAssertionFailed), + (ECode: e_External; EIdent: SExternalException), + (ECode: e_IntfCast; EIdent: SIntfCastError), + (ECode: e_SafeCall; EIdent: SSafecallException)); + +procedure ErrorHandler(ErrorCode: Integer; ErrorAddr: Pointer); +var + E: Exception; +begin + {case ErrorCode of + 1: E := OutOfMemory; + 2: E := InvalidPointer; + 3..24: with ExceptMap[ErrorCode] do E := EClass.Create(EIdent); + else + E := CreateInOutError; + end;} + + { + } + if ErrorCode <= 24 then + with ExceptMap[ErrorCode] do E := Exception.Create(ECode, EIdent) + else E := CreateInOutError; + { - } + + raise E at ErrorAddr; +end; + +{ Assertion error handler } + +{ This is complicated by the desire to make it look like the exception } +{ happened in the user routine, so the debugger can give a decent stack } +{ trace. To make that feasible, AssertErrorHandler calls a helper function } +{ to create the exception object, so that AssertErrorHandler itself does } +{ not need any temps. After the exception object is created, the asm } +{ routine RaiseAssertException sets up the registers just as if the user } +{ code itself had raised the exception. } + +function CreateAssertException(const Message, Filename: string; + LineNumber: Integer): Exception; +var + S: string; +begin + if Message <> '' then S := Message else S := SAssertionFailed; + Result := Exception.CreateFmt(e_Assertion, SAssertError, + [S, Filename, LineNumber]); +end; + +{ This code is based on the following assumptions: } +{ - Our direct caller (AssertErrorHandler) has an EBP frame } +{ - ErrorStack points to where the return address would be if the } +{ user program had called System.@RaiseExcept directly } +procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer); +asm + MOV ESP,ECX + MOV [ESP],EDX + MOV EBP,[EBP] + JMP System.@RaiseExcept +end; + +{ If you change this procedure, make sure it does not have any local variables } +{ or temps that need cleanup - they won't get cleaned up due to the way } +{ RaiseAssertException frame works. Also, it can not have an exception frame. } +procedure AssertErrorHandler(const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); +var + E: Exception; +begin + E := CreateAssertException(Message, Filename, LineNumber); + RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4); +end; + +{ Abstract method invoke error handler } + +procedure AbstractErrorHandler; +begin + raise Exception.Create(e_Abstract, SAbstractError); +end; + +{$IFDEF ASM_VERSION} +function MapException(P: PExceptionRecord): Byte; +asm //cmd //opd + MOV EAX, [EAX].TExceptionRecord.ExceptionCode + SUB EAX, $C0000000 + CMP EAX, $FD + JA @@code22 + + XOR ECX, ECX + MOV EDX, offset @@cvTable - 1 +@@loo: + INC EDX + MOV CL, [EDX] + JECXZ @@code22 + INC EDX + CMP AL, [EDX] + JNE @@loo + + MOV AL, CL + RET + +@@cvTable: + DB 3, $94 + DB 4, $8C + DB 5, $95 + DB 6, $8F, 6, $90, 6, $92 + DB 7, $8E + DB 8, $91 + DB 9, $8D, 9, $93 + DB 11, $05 + DB 12, $96 + DB 14, $FD + DB 0 + +@@code22: + MOV AL, 22 +end; +{$ELSE} //Pascal +function MapException(P: PExceptionRecord): Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: + Result := 3; + STATUS_ARRAY_BOUNDS_EXCEEDED: + Result := 4; + STATUS_INTEGER_OVERFLOW: + Result := 5; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: + Result := 6; + STATUS_FLOAT_DIVIDE_BY_ZERO: + Result := 7; + STATUS_FLOAT_OVERFLOW: + Result := 8; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: + Result := 9; + STATUS_ACCESS_VIOLATION: + Result := 11; + STATUS_PRIVILEGED_INSTRUCTION: + Result := 12; + STATUS_CONTROL_C_EXIT: + Result := 13; + STATUS_STACK_OVERFLOW: + Result := 14; + else + Result := 22; { must match System.reExternalException } + end; +end; +{$ENDIF} + +function GetExceptionClass(P: PExceptionRecord): ExceptClass; +//var ErrorCode: Byte; +begin + //ErrorCode := MapException(P); + Result := Exception; {ExceptMap[ErrorCode].EClass;} +end; + +function GetExceptionObject(P: PExceptionRecord): Exception; +var + ErrorCode: Integer; + + function CreateAVObject: Exception; + var + AccessOp: string; // string ID indicating the access type READ or WRITE + AccessAddress: Pointer; + MemInfo: TMemoryBasicInformation; + ModName: array[0..MAX_PATH] of KOLChar; + begin + with P^ do + begin + if ExceptionInformation[0] = 0 then + AccessOp := SReadAccess else + AccessOp := SWriteAccess; + AccessAddress := Pointer(ExceptionInformation[1]); + VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo)); + if (MemInfo.State = MEM_COMMIT) and (GetModuleFileName(THandle(MemInfo.AllocationBase), + ModName, SizeOf(ModName)) <> 0) then + Result := Exception.CreateFmt(e_AccessViolation, sModuleAccessViolation, + [ExceptionAddress, ExtractFileName(ModName), AccessOp, + AccessAddress]) + else Result := Exception.CreateFmt(e_AccessViolation, sAccessViolation, + [ExceptionAddress, AccessOp, AccessAddress]); + end; + end; + +begin + ErrorCode := MapException(P); + case ErrorCode of + 3..10, 12..21: + with ExceptMap[ErrorCode] do Result := Exception.Create(ECode, EIdent); + 11: Result := CreateAVObject; + else + begin + Result := Exception.CreateFmt(e_External, SExternalException, [P.ExceptionCode]); + //Result.FExceptionRecord := P; + end; + end; + Result.FExceptionRecord := P; +end; + +{ RTL exception handler } + +procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far; +begin + ShowException(ExceptObject, ExceptAddr); + Halt(1); +end; + +{+} +function InitAssertErrorProc: Boolean; +begin + AssertErrorProc := @AssertErrorHandler; + Result := TRUE; +end; +{-} + +procedure InitExceptions; +begin + {OutOfMemory := EOutOfMemory.Create(SOutOfMemory); + InvalidPointer := EInvalidPointer.Create(SInvalidPointer);} + ErrorProc := @ErrorHandler; + ExceptProc := @ExceptHandler; + ExceptionClass := Exception; + + ExceptClsProc := @GetExceptionClass; + + ExceptObjProc := @GetExceptionObject; + + {AssertErrorProc := @AssertErrorHandler;} + {+} // Initialize Assert only when "Assertions" option is turned on in Compiler: + Assert( InitAssertErrorProc, '' ); + {-} + + //AbstractErrorProc := @AbstractErrorHandler; + // {-} KOL does not use classes, so EAbstractError should never be raised. + +end; + +procedure DoneExceptions; +begin + {OutOfMemory.AllowFree := True; + OutOfMemory.FreeInstance; + OutOfMemory := nil; + InvalidPointer.AllowFree := True; + InvalidPointer.Free; + InvalidPointer := nil;} + ErrorProc := nil; + ExceptProc := nil; + ExceptionClass := nil; + //ExceptClsProc := nil; --see InitExceptions + ExceptObjProc := nil; + AssertErrorProc := nil; +end; + +{ RaiseLastWin32Error } + +procedure RaiseLastWin32Error; +var + LastError: DWORD; + Error: Exception; +begin + LastError := GetLastError; + if LastError <> ERROR_SUCCESS then + Error := Exception.CreateFmt(e_Win32, SWin32Error, [LastError, + SysErrorMessage(LastError)]) + else + Error := Exception.Create(e_Win32, SUnkWin32Error ); + Error.ErrorCode := LastError; + raise Error; +end; + +{ Win32Check } + +function Win32Check(RetVal: BOOL): BOOL; +begin + if not RetVal then RaiseLastWin32Error; + Result := RetVal; +end; + +type + PTerminateProcInfo = ^TTerminateProcInfo; + TTerminateProcInfo = record + Next: PTerminateProcInfo; + Proc: TTerminateProc; + end; + +var + TerminateProcList: PTerminateProcInfo = nil; + +procedure AddTerminateProc(TermProc: TTerminateProc); +var + P: PTerminateProcInfo; +begin + New(P); + P^.Next := TerminateProcList; + P^.Proc := TermProc; + TerminateProcList := P; +end; + +function CallTerminateProcs: Boolean; +var + PI: PTerminateProcInfo; +begin + Result := True; + PI := TerminateProcList; + while Result and (PI <> nil) do + begin + Result := PI^.Proc; + PI := PI^.Next; + end; +end; + +procedure FreeTerminateProcs; +var + PI: PTerminateProcInfo; +begin + while TerminateProcList <> nil do + begin + PI := TerminateProcList; + TerminateProcList := PI^.Next; + Dispose(PI); + end; +end; + +{ --- } + +function AL1(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + XOR EDX,DWORD PTR [P+4] + XOR EDX,DWORD PTR [P+8] + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +function AL2(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + ROR EDX,5 + XOR EDX,DWORD PTR [P+4] + ROR EDX,5 + XOR EDX,DWORD PTR [P+8] + ROR EDX,5 + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +const + AL1s: array[0..2] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0); + AL2s: array[0..2] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E); + +procedure ALV; +begin + raise Exception.Create(e_License, SNL); +end; + +{$IFNDEF _D2} +function ALR: Pointer; +var + LibModule: PLibModule; +begin + if MainInstance <> 0 then + Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL', + PKOLChar( RT_RCDATA )))) + else + begin + Result := nil; + LibModule := LibModuleList; + while LibModule <> nil do + begin + with LibModule^ do + begin + Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL', + PKOLChar( RT_RCDATA )))); + if Result <> nil then Break; + end; + LibModule := LibModule.Next; + end; + end; + if Result = nil then ALV; +end; + +function GDAL: LongWord; +type + TDVCLAL = array[0..3] of LongWord; + PDVCLAL = ^TDVCLAL; +var + P: Pointer; + A1, A2: LongWord; + PAL1s, PAL2s: PDVCLAL; + ALOK: Boolean; +begin + P := ALR; + A1 := AL1(P^); + A2 := AL2(P^); + Result := A1; + PAL1s := @AL1s; + PAL2s := @AL2s; + ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or + ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or + ((A1 = PAL1s[2]) and (A2 = PAL2s[2])); + FreeResource(Integer(P)); + if not ALOK then ALV; +end; + +procedure RCS; +var + P: Pointer; + ALOK: Boolean; +begin + P := ALR; + ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]); + FreeResource(Integer(P)); + if not ALOK then ALV; +end; + +procedure RPR; +var + AL: LongWord; +begin + AL := GDAL; + if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV; +end; +{$ENDIF} + +{$IFNDEF _D2orD3} +function SafeLoadLibrary(const Filename: KOLString; ErrorMode: UINT): HMODULE; +var + OldMode: UINT; + FPUControlWord: Word; +begin + OldMode := SetErrorMode(ErrorMode); + try + asm + FNSTCW FPUControlWord + end; + try + Result := LoadLibrary(PKOLChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; + finally + SetErrorMode(OldMode); + end; +end; +{$ENDIF} + +{procedure Exception.FreeInstance; +begin + if FAllowFree then + inherited; +end;} + + + +initialization + InitExceptions; + +finalization + FreeTerminateProcs; + DoneExceptions; + +end. + diff --git a/Addons/kolTCPSocket.pas b/Addons/kolTCPSocket.pas new file mode 100644 index 0000000..937e1ba --- /dev/null +++ b/Addons/kolTCPSocket.pas @@ -0,0 +1,972 @@ +unit kolTCPSocket; + +//////////////////////////////////////////////////////////////////// +// +// TTTTTTTTTT CCCCCCCC PPPPPPPPP +// T TTTT T CCCC CCCC PPPP PPPP +// TTTT CCCC PPPP PPPP +// TTTT CCCC PPPP PPPP +// TTTT CCCC PPPPPPPPP +// TTTT CCCC CCCC PPPP +// TTTT CCCCCCCC PPPP +// +// S O C K E T +// +// TCPServer, TCPClient implementation for Key Objects Library +// +// (c) 2002 by Vorobets Roman +// Roman.Vorobets@p25.f8.n454.z2.fidonet.org +// +//////////////////////////////////////////////////////////////////// + +interface + +uses + kol,windows,winsock,messages; + +const + WM_SOCKET=WM_USER+1; + WM_SOCKETDESTROY=WM_USER+2; + +type + twndmethod=procedure(var message:tmessage) of object; + + PTCPBase=^TTCPBase; + PTCPServer=^TTCPServer; + PTCPClient=^TTCPClient; + PTCPServerClient=^TTCPServerClient; + + TKOLTCPClient=PTCPClient; + TKOLTCPServer=PTCPServer; + + TOnTCPClientEvent = procedure(Sender: PTCPClient) of object; + TOnTCPStreamSend = TOnTCPClientEvent; + TOnTCPStreamReceive = TOnTCPClientEvent; + TOnTCPConnect = TOnTCPClientEvent; + TOnTCPManualReceive = TOnTCPClientEvent; + TOnTCPDisconnect = TOnTCPClientEvent; + + TOnTCPReceive = procedure(Sender: PTCPClient; var Buf: array of byte; const Count: Integer) of object; + TOnTCPResolve = procedure(Sender: PTCPClient; const IP: String) of object; + TOnTCPAccept = function(Sender: PTCPServer; const IP: String; + const Port: SmallInt):boolean of object; + TOnTCPClientConnect = procedure(Sender: PTCPServerClient) of object; + TOnTCPError = procedure(Sender: PObj; const Error:integer) of object; + + TTCPBase=object(TObj) + private + FWnd:HWnd; + FConnecting: Boolean; + function GetWnd: HWnd; + procedure Method(var message:tmessage);virtual; + procedure DoClose; + private + FPort: SmallInt; + FOnConnect: TOnTCPConnect; + FOnDisconnect: TOnTCPDisconnect; + FOnError: TOnTCPError; + FHandle: TSocket; + FConnected: Boolean; + FSection: TRTLCriticalSection; + property Wnd:HWnd read GetWnd; + function GetPort: SmallInt; + procedure SetPort(const Value: SmallInt); + procedure SetOnConnect(const Value: TOnTCPConnect); + procedure SetOnDisconnect(const Value: TOnTCPDisconnect); + procedure SetOnError(const Value: TOnTCPError); + procedure SetHandle(const Value: TSocket); + function ErrorTest(const e: integer): boolean; + protected + procedure Creating;virtual; + destructor Destroy;virtual; + public + property Connected:Boolean read FConnected; + property Online:Boolean read FConnected; + property Connecting:Boolean read FConnecting; + property Handle:TSocket read FHandle write SetHandle; + property Port:SmallInt read GetPort{FPort} write SetPort; + property OnError:TOnTCPError read FOnError write SetOnError; + property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect; + property OnDisconnect:TOnTCPDisconnect read FOnDisconnect write SetOnDisconnect; + procedure Lock; + procedure Unlock; + procedure Disconnect;virtual; + end; + + TTCPServer=object(TTCPBase) + private + FConnections: PList; + FOnAccept: TOnTCPAccept; + FOnClientConnect: TOnTCPClientConnect; + FOnClientDisconnect: TOnTCPDisconnect; + FOnClientError: TOnTCPError; + FOnClientReceive: TOnTCPReceive; + FOnClientManualReceive: TOnTCPManualReceive; + FOnClientStreamReceive: TOnTCPStreamReceive; + FOnClientStreamSend: TOnTCPStreamSend; + procedure SetOnAccept(const Value: TOnTCPAccept); + procedure SetOnClientConnect(const Value: TOnTCPClientConnect); + procedure SetOnClientDisconnect(const Value: TOnTCPDisconnect); + procedure SetOnClientError(const Value: TOnTCPError); + procedure SetOnClientReceive(const Value: TOnTCPReceive); + function GetConnection(Index: Integer): PTCPServerClient; + function GetCount: Integer; + procedure Method(var message: tmessage); virtual; + procedure SetOnClientManualReceive(const Value: TOnTCPManualReceive); + procedure SetOnClientStreamReceive(const Value: TOnTCPStreamReceive); + procedure SetOnClientStreamSend(const Value: TOnTCPStreamSend); + protected + procedure Creating;virtual; + destructor Destroy;virtual; + public + property OnAccept:TOnTCPAccept read FOnAccept write SetOnAccept; + property OnClientError:TOnTCPError read FOnClientError write SetOnClientError; + property OnClientConnect:TOnTCPClientConnect read FOnClientConnect write SetOnClientConnect; + property OnClientDisconnect:TOnTCPDisconnect read FOnClientDisconnect write SetOnClientDisconnect; + property OnClientReceive:TOnTCPReceive read FOnClientReceive write SetOnClientReceive; + property OnClientManualReceive:TOnTCPManualReceive read FOnClientManualReceive write SetOnClientManualReceive; + property OnClientStreamSend:TOnTCPStreamSend read FOnClientStreamSend write SetOnClientStreamSend; + property OnClientStreamReceive:TOnTCPStreamReceive read FOnClientStreamReceive write SetOnClientStreamReceive; + property Count:Integer read GetCount; + property Connection[Index: Integer]: PTCPServerClient read GetConnection; + procedure Listen; + procedure Disconnect;virtual; + end; + + TTCPClient=object(TTCPBase) + private + FHost: String; + FBuffer: array[0..4095] of byte; + FOnResolve: TOnTCPResolve; + FOnReceive: TOnTCPReceive; + FOnStreamSend: TOnTCPStreamSend; + FSendStream: PStream; + FSendAutoFree: Boolean; + FReceiveStream: PStream; + FReceiveAutoFree: Boolean; + FReceiveAutoFreeSize: Integer; + FReceiveStartPos: Integer; + FOnManualReceive: TOnTCPManualReceive; + FOnStreamReceive: TOnTCPStreamReceive; + FIndex: Integer; + procedure SetHost(const Value: String); + procedure SetOnResolve(const Value: TOnTCPResolve); + procedure SetOnReceive(const Value: TOnTCPReceive); + procedure SetOnStreamSend(const Value: TOnTCPStreamSend); + procedure Method(var message:tmessage);virtual; + function SendStreamPiece: Boolean; + procedure SetOnManualReceive(const Value: TOnTCPManualReceive); + procedure SetOnStreamReceive(const Value: TOnTCPStreamReceive); + procedure SetIndex(const Value: Integer);virtual; + protected + destructor Destroy;virtual; + public + property OnReceive:TOnTCPReceive read FOnReceive write SetOnReceive; + property OnManualReceive:TOnTCPManualReceive read FOnManualReceive write SetOnManualReceive; + property OnResolve:TOnTCPResolve read FOnResolve write SetOnResolve; + property OnStreamSend:TOnTCPStreamSend read FOnStreamSend write SetOnStreamSend; + property OnStreamReceive:TOnTCPStreamReceive read FOnStreamReceive write SetOnStreamReceive; + property Host:String read FHost write SetHost; + property Index:Integer read FIndex write SetIndex; + function StreamSending:Boolean; + function StreamReceiving:Boolean; + procedure Connect;virtual; + function Send(var Buf; const Count: Integer): Integer; + procedure SendString(S: String); + function SendStream(Stream: PStream; const AutoFree: Boolean): Boolean; + procedure SetReceiveStream(Stream: PStream; const AutoFree: Boolean=false; + const AutoFreeSize: Integer=0); + function ReceiveLength: Integer; + function ReceiveBuf(var Buf; Count: Integer): Integer; + end; + + TTCPServerClient=object(TTCPClient) + private + FIP: String; + FServer: PTCPServer; + procedure SetIndex(const Value: Integer);virtual; + public + property IP: String read FIP; + procedure Connect;virtual; + procedure Disconnect;virtual; + end; + +function NewTCPServer: PTCPServer; +function NewTCPClient: PTCPClient; +function Err2Str(const id: integer): string; +function TCPGetHostByName(name: pchar): string; + +procedure Startup; +procedure Cleanup; + +implementation + +type + pobjectinstance=^tobjectinstance; + tobjectinstance=packed record + code:byte; + offset:integer; + case integer of + 0:(next:pobjectinstance); + 1:(method:twndmethod); + end; + + pinstanceblock=^tinstanceblock; + tinstanceblock=packed record + next:pinstanceblock; + code:array[1..2] of byte; + wndprocptr:pointer; + instances: array[0..$ff] of tobjectinstance; + end; + +var + instblocklist:pinstanceblock; + instfreelist:pobjectinstance; + + wsadata:twsadata; + +function NewTCPServerClient(Server: PTCPServer): PTCPServerClient;forward; + +function stdwndproc(window:hwnd;message:dword;wparam:WPARAM; + lparam:LPARAM):LRESULT;stdcall;assembler; +asm + XOR EAX,EAX + PUSH EAX + PUSH LParam + PUSH WParam + PUSH Message + MOV EDX,ESP + MOV EAX,[ECX].Longint[4] + CALL [ECX].Pointer + ADD ESP,12 + POP EAX +end; + +function calcjmpoffset(src,dest:pointer):longint; +begin + result:=longint(dest)-(longint(src)+5); +end; + +function MakeObjectInstance(Method: TWndMethod): Pointer; +const + blockcode:array[1..2] of byte=($59,$E9); + pagesize=4096; +var + block:pinstanceblock; + instance:pobjectinstance; +begin + if instfreelist=nil then + begin + block:=virtualalloc(nil,PageSize, MEM_COMMIT,PAGE_EXECUTE_READWRITE); + block^.next:=instblocklist; + move(blockcode,block^.code,sizeof(blockcode)); + block^.wndprocptr:=pointer(calcjmpoffset(@block^.code[2],@stdwndproc)); + instance:=@block^.instances; + repeat + instance^.code:=$E8; + instance^.offset:=calcjmpoffset(instance,@block^.code); + instance^.next:=instfreelist; + instfreelist:=instance; + inc(longint(instance),sizeof(tobjectinstance)); + until longint(instance)-longint(block)>=sizeof(tinstanceblock); + instblocklist:=block; + end; + result:=instfreelist; + instance:=instfreelist; + instfreelist:=instance^.next; + instance^.method:=method; +end; + +procedure FreeObjectInstance(ObjectInstance: Pointer); +begin + if objectinstance<>nil then + begin + pobjectinstance(objectinstance)^.next:=instfreelist; + instfreelist:=objectinstance; + end; +end; + +var + utilclass:twndclass=(lpfnwndproc:@defwindowproc;lpszclassname:'TCPSocket'); + +function AllocateHWnd(Method: TWndMethod): HWND; +var + tempclass:twndclass; + classregistered:boolean; +begin + utilclass.hinstance:=hinstance; + classregistered:=getclassinfo(hinstance,utilclass.lpszclassname,tempclass); + if not classregistered or (tempclass.lpfnwndproc<>@defwindowproc) then + begin + if classregistered then unregisterclass(utilclass.lpszclassname,hinstance); + registerclass(utilclass); + end; + result:=createwindowex(WS_EX_TOOLWINDOW,utilclass.lpszclassname,nil, + WS_POPUP,0,0,0,0,0,0,hinstance,nil); + if assigned(method) then setwindowlong(result,GWL_WNDPROC,longint(makeobjectinstance(method))); +end; + +procedure DeallocateHWnd(Wnd: HWND); +var + instance:pointer; +begin + instance:=pointer(getwindowlong(wnd,GWL_WNDPROC)); + destroywindow(wnd); + if instance<>@defwindowproc then freeobjectinstance(instance); +end; + +procedure Startup; +begin + if bool(wsastartup($101,wsadata)) then showmessage('WSAStartup error.'); +end; + +procedure Cleanup; +begin + if bool(wsacleanup) then showmessage('WSACleanup error'); +end; + +{ TTCPBase } + +procedure TTCPBase.Creating; +begin + startup; + initializecriticalsection(fsection); + fhandle:=SOCKET_ERROR; +end; + +destructor TTCPBase.Destroy; +begin + if fwnd<>0 then deallocatehwnd(fwnd); + doclose; + disconnect; + deletecriticalsection(fsection); + cleanup; +end; + +procedure TTCPBase.Disconnect; +begin + if fhandle<>SOCKET_ERROR then + begin + doclose; + if fconnected then + begin + fconnected:=false; + if assigned(ondisconnect) then ondisconnect(@self); + end; + fconnecting:=false; + end; +end; + +procedure TTCPBase.DoClose; +begin + if fhandle<>SOCKET_ERROR then + begin + errortest(closesocket(fhandle)); + fhandle:=SOCKET_ERROR; + end; +end; + +function TTCPBase.ErrorTest(const e: integer): boolean; +var + wsae: Integer; +begin +{ msgok(int2str(e)); + msgok(int2str(SOCKET_ERROR)); + msgok(int2str(INVALID_SOCKET)); } + + result:= (e = SOCKET_ERROR) or (e = INVALID_SOCKET); + if result then begin + wsae:=wsagetlasterror; + if wsae<>WSAEWOULDBLOCK then + begin + if assigned(onerror) then onerror(@self,wsae) else + showmessage('Socket error '+err2str(wsae)+' on socket '+int2str(fhandle)); + end else result:=false; + end; +end; + +function TTCPBase.GetWnd: HWnd; +begin + if fwnd=0 then fwnd:=allocatehwnd(method); + result:=fwnd; +end; + +procedure TTCPBase.Lock; +begin + entercriticalsection(fsection); +end; + +procedure TTCPBase.Method(var message: tmessage); +begin + if message.msg<>WM_SOCKET then exit; + if message.lparamhi>WSABASEERR then + begin + wsasetlasterror(message.lparamhi); + errortest(SOCKET_ERROR); + if fconnecting then doclose; + fconnecting:=false; + end; + case message.lparamlo of + FD_CLOSE:begin + fconnected:=false; + fconnecting:=false; + if assigned(ondisconnect) then ondisconnect(@self); + if fhandle<>SOCKET_ERROR then doclose; + end; + end; +end; + +procedure TTCPBase.SetHandle(const Value: TSocket); +begin + FHandle := Value; +end; + +procedure TTCPBase.SetOnDisconnect(const Value: TOnTCPDisconnect); +begin + FOnDisconnect := Value; +end; + +procedure TTCPBase.SetOnError(const Value: TOnTCPError); +begin + FOnError := Value; +end; + +procedure TTCPBase.SetPort(const Value: SmallInt); +begin + FPort := Value; +end; + +function TTCPBase.GetPort: SmallInt; +var buf: sockaddr_in; bufSz: Integer; +begin + if FConnected then + begin + bufSz := SizeOf(buf); + ZeroMemory( @buf, bufSz ); + getsockname(fhandle, buf, bufSz); + FPort := htons(buf.sin_port); + end; + Result := FPort; +end; + +function NewTCPServer: PTCPServer; +begin + new(result,create); + result.creating; +end; + +function NewTCPClient: PTCPClient; +begin + new(result,create); + result.creating; +end; + +function NewTCPServerClient(Server: PTCPServer): PTCPServerClient; +begin + new(result,create); + result.creating; + result.fserver:=server; +end; + +procedure TTCPBase.Unlock; +begin + leavecriticalsection(fsection); +end; + +{ TTCPClient } + +procedure TTCPClient.Connect; +var + adr: TSockAddr; +begin + disconnect; + fhandle:= socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); + if not errortest(fhandle) then begin + WSAAsyncSelect(fhandle, wnd, WM_SOCKET, FD_READ or FD_WRITE or FD_CONNECT or FD_CLOSE); + with adr do begin + sin_family:= AF_INET; + sin_port:= htons(port); + //Integer(sin_addr):= inet_addr(PChar(host)); + sin_addr.S_addr:= inet_addr(PChar(host)); + + if Integer(sin_addr) = SOCKET_ERROR then begin + sin_addr.S_addr:= PInAddr(gethostbyname(PChar(Host)).h_addr_list^)^.S_addr; + end; + +//msgok('bly' + int2str(sin_addr.S_addr)); + {if Integer(sin_addr) = SOCKET_ERROR then begin + // must be WSAAsyncGetHostByName + ph:= winsock.gethostbyname(pchar(host)); + if ph=nil then showmessage('gethostbyname() error'); + move(ph.h_addr^^,sin_addr,ph.h_length); + if assigned(onresolve) then onresolve(@self,inet_ntoa(adr.sin_addr)); + end;} + + end; + fconnecting:= not errortest(Integer(adr.sin_addr)) and not errortest(WinSock.connect(fhandle, adr, SizeOf(adr))); + if not fconnecting then doclose; + end; +end; + +destructor TTCPClient.Destroy; +begin + if fsendautofree and (fsendstream<>nil) then fsendstream.free; + fsendstream:=nil; + inherited; +end; + +function TTCPClient.StreamReceiving: Boolean; +begin + Result:= Assigned(FReceiveStream); +end; + +function TTCPClient.StreamSending: Boolean; +begin + Result:= Bool(fsendstream); +end; + +procedure TTCPClient.Method(var message: tmessage); +var + sz:integer; +begin + inherited; + if (message.msg<>WM_SOCKET) then exit; + if message.lparamhi>WSABASEERR then + begin + if message.lparamlo=FD_CLOSE then + begin + if streamsending then + begin + if fsendautofree then fsendstream.free; + if assigned(onstreamsend) then onstreamsend(@self); + end; + if streamreceiving then + begin + if freceiveautofree then freceivestream.free; + if assigned(onstreamreceive) then onstreamreceive(@self); + end; + end; + end else + case message.lparamlo of + FD_CONNECT:begin + fconnected:=true; + fconnecting:=false; + if assigned(onconnect) then onconnect(@self); + end; + FD_READ:if (freceivestream=nil) and assigned(onmanualreceive) then onmanualreceive(@self) else + begin + lock; +// repeat + ioctlsocket(fhandle,FIONREAD,sz); + if sz>0 then + begin + if sz>sizeof(fbuffer) then sz:=sizeof(fbuffer); + sz:=receivebuf(fbuffer,sz); + errortest(sz); + if freceivestream<>nil then + begin + freceivestream.write(fbuffer,sz); + if assigned(onstreamreceive) then onstreamreceive(@self); + end else if assigned(onreceive) then onreceive(@self,fbuffer,sz); + end; +// until (sz<=0) or //not fmaxsendstreamspeed or +// ((freceivestream<>nil) and freceiveautofree and +// (freceivestream.size>=freceiveautofreesize)); + unlock; + if (freceivestream<>nil) and freceiveautofree and + (integer(freceivestream.position)+freceivestartpos>=freceiveautofreesize) then + begin + freceivestream.free; + freceivestream:=nil; + if assigned(onstreamreceive) then onstreamreceive(@self); + end; + end; + FD_WRITE:if streamsending then sendstreampiece;// else if assigned(onwrite) then onwrite(@self); + end; +end; + +function TTCPClient.ReceiveBuf(var Buf; Count: Integer): Integer; +begin + result:=0; + if not fconnected or (fhandle=SOCKET_ERROR) or (count<=0) then exit; + lock; + result:=recv(fhandle,buf,count,0); + errortest(result); + unlock; +end; + +function TTCPClient.ReceiveLength: Integer; +begin + ioctlsocket(fhandle,FIONREAD,result); +end; + +function TTCPClient.Send(var Buf; const Count: Integer): Integer; +begin + result:=winsock.send(fhandle,buf,count,0); +end; + +function TTCPClient.SendStream(Stream: PStream; const AutoFree: Boolean): Boolean; +begin + result:=false; + if fsendstream=nil then + begin + fsendstream:=stream; + fsendautofree:=autofree; + result:=sendstreampiece; + end; +end; + +function TTCPClient.SendStreamPiece: Boolean; +var + buf:array[0..4095] of byte; + startpos,amountinbuf,amountsent:integer; +begin + result:=false; + if not fconnected or (fhandle=SOCKET_ERROR) or (fsendstream=nil) then exit; + lock; + repeat + startpos:=fsendstream.position; + amountinbuf:=fsendstream.read(buf,sizeof(buf)); + if amountinbuf>0 then + begin + amountsent:=send(buf,amountinbuf); + if amountsent=SOCKET_ERROR then + begin + if errortest(SOCKET_ERROR) then + begin + fsendstream:=nil; + break; + end else + begin + fsendstream.position:=startpos; + break; + end; + end else + if amountinbuf>amountsent then fsendstream.position:=startpos+amountsent else + if fsendstream.position=fsendstream.size then + begin + if fsendautofree then fsendstream.free; + fsendstream:=nil; + break; + end; + end else + begin + fsendstream:=nil; + break; + end; + until false; + result:=true; + unlock; + if assigned(onstreamsend) then onstreamsend(@self); +end; + +procedure TTCPClient.SendString(S: String); +begin + send(s[1], length(s)); +end; + +procedure TTCPClient.SetHost(const Value: String); +begin + FHost := Value; +end; + +procedure TTCPClient.SetIndex(const Value: Integer); +begin + FIndex := Value; +end; + +procedure TTCPBase.SetOnConnect(const Value: TOnTCPConnect); +begin + FOnConnect := Value; +end; + +procedure TTCPClient.SetOnManualReceive(const Value: TOnTCPManualReceive); +begin + FOnManualReceive := Value; +end; + +procedure TTCPClient.SetOnReceive(const Value: TOnTCPReceive); +begin + FOnReceive := Value; +end; + +procedure TTCPClient.SetOnResolve(const Value: TOnTCPResolve); +begin + FOnResolve := Value; +end; + +procedure TTCPClient.SetOnStreamReceive(const Value: TOnTCPStreamReceive); +begin + FOnStreamReceive := Value; +end; + +procedure TTCPClient.SetOnStreamSend(const Value: TOnTCPStreamSend); +begin + FOnStreamSend := Value; +end; + +procedure TTCPClient.SetReceiveStream(Stream: PStream; const AutoFree: Boolean = False; const AutoFreeSize: Integer=0); +begin + if Autofree and (AutoFreeSize = 0) then Exit; + if Assigned(FReceiveStream) then FReceiveStream.free; + FReceiveAutoFree:= AutoFree; + FReceiveAutoFreeSize:= AutoFreeSize; + FReceiveStartpos:= Stream.Position; + FReceiveStream:= Stream; +end; + +{ TTCPServer } + +procedure TTCPServer.Creating; +begin + inherited; + fconnections:=newlist; +end; + +destructor TTCPServer.Destroy; +var + i:integer; +begin + for i:=0 to pred(count) do connection[i].free; + fconnections.free; + fconnections:=nil; + inherited; +end; + +procedure TTCPServer.Disconnect; +begin + if fconnections=nil then exit; + lock; + while count>0 do connection[0].disconnect; + unlock; + inherited; +end; + +function TTCPServer.GetConnection(Index: Integer): PTCPServerClient; +begin + result:=ptcpserverclient(fconnections.items[index]); +end; + +function TTCPServer.GetCount: Integer; +begin + result:=fconnections.count; +end; + +procedure TTCPServer.Listen; +var + adr:tsockaddr; +begin + if fhandle<>SOCKET_ERROR then exit; + fhandle:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP); + if not errortest(fhandle) then + begin + with adr do + begin + sin_family:=AF_INET; + sin_port:=htons(port); + integer(sin_addr):=INADDR_ANY; + end; + if errortest(bind(fhandle,adr,sizeof(adr))) then doclose else + begin + wsaasyncselect(fhandle,wnd,WM_SOCKET,FD_ACCEPT or FD_CLOSE or FD_CONNECT); + if errortest(winsock.listen(fhandle,64)) then + doclose + else + begin + FConnected := True; + if assigned(onconnect) then onconnect(@self); + end; + end; + end; +end; + +procedure TTCPServer.Method(var message: tmessage); +var + adr:tsockaddr; + sz:integer; + sock:TSocket; + sclient:ptcpserverclient; +begin + inherited; + case message.msg of + WM_SOCKET: + if message.lparamhi<=WSABASEERR then + case message.lparamlo of + FD_ACCEPT:begin + sz:=sizeof(adr); + sock:=accept(fhandle,@adr,@sz); + if not errortest(sock) then + begin + if not assigned(onaccept) or onaccept(@self,inet_ntoa(adr.sin_addr),htons(adr.sin_port)) then + begin + sclient:=newtcpserverclient(@self); + with sclient^ do + begin + wsaasyncselect(sock,wnd,WM_SOCKET,FD_READ or FD_WRITE or FD_CLOSE); + fhost:=inet_ntoa(adr.sin_addr); + fport:=htons(adr.sin_port); + fip:=fhost; + fhandle:=sock; + fconnected:=true; + fconnecting:=false; + findex:=fconnections.count; + onerror:=onclienterror; + ondisconnect:=onclientdisconnect; + onreceive:=onclientreceive; + onmanualreceive:=onclientmanualreceive; + onstreamsend:=onclientstreamsend; + onstreamreceive:=onclientstreamreceive; + end; + fconnections.add(sclient); + if assigned(onclientconnect) then onclientconnect(sclient); + end else closesocket(sock); + end; + end; + end; + WM_SOCKETDESTROY:ptcpserverclient(message.wparam).free; + end; +end; + +procedure TTCPServer.SetOnAccept(const Value: TOnTCPAccept); +begin + FOnAccept := Value; +end; + +procedure TTCPServer.SetOnClientConnect(const Value: TOnTCPClientConnect); +begin + FOnClientConnect := Value; +end; + +procedure TTCPServer.SetOnClientDisconnect(const Value: TOnTCPDisconnect); +begin + FOnClientDisconnect := Value; +end; + +procedure TTCPServer.SetOnClientError(const Value: TOnTCPError); +begin + FOnClientError := Value; +end; + +procedure TTCPServer.SetOnClientManualReceive( const Value: TOnTCPManualReceive); +begin + FOnClientManualReceive := Value; +end; + +procedure TTCPServer.SetOnClientReceive(const Value: TOnTCPReceive); +begin + FOnClientReceive := Value; +end; + +function Err2Str(const id: integer): string; +begin + case id of + WSAEINTR:result:='WSAEINTR'; + WSAEBADF:result:='WSAEBADF'; + WSAEACCES:result:='WSAEACCES'; + WSAEFAULT:result:='WSAEFAULT'; + WSAEINVAL:result:='WSAEINVAL'; + WSAEMFILE:result:='WSAEMFILE'; + WSAEWOULDBLOCK:result:='WSAEWOULDBLOCK'; + WSAEINPROGRESS:result:='WSAEINPROGRESS'; + WSAEALREADY:result:='WSAEALREADY'; + WSAENOTSOCK:result:='WSAENOTSOCK'; + WSAEDESTADDRREQ:result:='WSAEDESTADDRREQ'; + WSAEMSGSIZE:result:='WSAEMSGSIZE'; + WSAEPROTOTYPE:result:='WSAEPROTOTYPE'; + WSAENOPROTOOPT:result:='WSAENOPROTOOPT'; + WSAEPROTONOSUPPORT:result:='WSAEPROTONOSUPPORT'; + WSAESOCKTNOSUPPORT:result:='WSAESOCKTNOSUPPORT'; + WSAEOPNOTSUPP:result:='WSAEOPNOTSUPP'; + WSAEPFNOSUPPORT:result:='WSAEPFNOSUPPORT'; + WSAEAFNOSUPPORT:result:='WSAEAFNOSUPPORT'; + WSAEADDRINUSE:result:='WSAEADDRINUSE'; + WSAEADDRNOTAVAIL:result:='WSAEADDRNOTAVAIL'; + WSAENETDOWN:result:='WSAENETDOWN'; + WSAENETUNREACH:result:='WSAENETUNREACH'; + WSAENETRESET:result:='WSAENETRESET'; + WSAECONNABORTED:result:='WSAECONNABORTED'; + WSAECONNRESET:result:='WSAECONNRESET'; + WSAENOBUFS:result:='WSAENOBUFS'; + WSAEISCONN:result:='WSAEISCONN'; + WSAENOTCONN:result:='WSAENOTCONN'; + WSAESHUTDOWN:result:='WSAESHUTDOWN'; + WSAETOOMANYREFS:result:='WSAETOOMANYREFS'; + WSAETIMEDOUT:result:='WSAETIMEDOUT'; + WSAECONNREFUSED:result:='WSAECONNREFUSED'; + WSAELOOP:result:='WSAELOOP'; + WSAENAMETOOLONG:result:='WSAENAMETOOLONG'; + WSAEHOSTDOWN:result:='WSAEHOSTDOWN'; + WSAEHOSTUNREACH:result:='WSAEHOSTUNREACH'; + WSAENOTEMPTY:result:='WSAENOTEMPTY'; + WSAEPROCLIM:result:='WSAEPROCLIM'; + WSAEUSERS:result:='WSAEUSERS'; + WSAEDQUOT:result:='WSAEDQUOT'; + WSAESTALE:result:='WSAESTALE'; + WSAEREMOTE:result:='WSAEREMOTE'; + WSASYSNOTREADY:result:='WSASYSNOTREADY'; + WSAVERNOTSUPPORTED:result:='WSAVERNOTSUPPORTED'; + WSANOTINITIALISED:result:='WSANOTINITIALISED'; + WSAHOST_NOT_FOUND:result:='WSAHOST_NOT_FOUND'; + WSATRY_AGAIN:result:='WSATRY_AGAIN'; + WSANO_RECOVERY:result:='WSANO_RECOVERY'; + WSANO_DATA:result:='WSANO_DATA'; + else result:='WSAEUNKNOWN'; + end; +end; + +procedure TTCPServer.SetOnClientStreamReceive( const Value: TOnTCPStreamReceive); +begin + FOnClientStreamReceive := Value; +end; + +procedure TTCPServer.SetOnClientStreamSend(const Value: TOnTCPStreamSend); +begin + FOnClientStreamSend := Value; +end; + +{ TTCPServerClient } + +procedure TTCPServerClient.Connect; +begin + showmessage('Can''t connect ServerClient'); +end; + +procedure TTCPServerClient.Disconnect; +var + i,j:integer; + srv:ptcpserver; +begin + if fserver<>nil then + begin + srv:=fserver; + fserver:=nil; + srv.lock; + i:=srv.fconnections.indexof(@self); + for j:=pred(srv.fconnections.count) downto succ(i) do dec(srv.connection[j].findex); + srv.fconnections.delete(i); + srv.unlock; + postmessage(srv.wnd,WM_SOCKETDESTROY,integer(@self),0); + end; + inherited; +end; + +function TCPGetHostByName(name: pchar): string; +var + host:phostent; + adr:in_addr; +begin + host:=gethostbyname(name); + move(host.h_addr^^,adr,host.h_length); + result:=inet_ntoa(adr); +end; + +procedure TTCPServerClient.SetIndex(const Value: Integer); +begin + showmessage('Can''t set index of ServerClient'); +end; + +initialization + instblocklist:=nil; + instfreelist:=nil; + +end. diff --git a/Addons/mckBlockCipher.dcr b/Addons/mckBlockCipher.dcr new file mode 100644 index 0000000000000000000000000000000000000000..70b95bc8229b97a6d7cb26f21ceae2781541a8d9 GIT binary patch literal 8844 zcmds-&2rsD5QQfc3)p4JGD{XLz$6q~NDLTAOxdoYcpEQyEI)usPof&Vfy8%C&*;iG zxjdP+_uYF+g2M+Dl#^cJn3y%^cc!U_oF{9#N+TR{2kGR-&c0s z2EVKHI=w`vwpPrJc(gqx0fapiVBuoS?eje5Ngf3;dW{E;&h)Lk8}>d`HX1oH88wy! zx8;Z52s7a`=iCi^yWC>jTCsafz5x;oYZeZo3A7QW$N(ym9gxj6`slLwW&5rHX!bld zvViWRe_dmL6Lw#3VRw<5VikffjDrx+lQAp_ZrNu$$HHl+N~M8?3Ci1L+lYH!vE;yUIW?A;D0}nSbv2?IZY~R|4~mkZE{{l_s<9uHbbnDnza_)g2;kG^Jbwy_TmHhUGcY<@~ziM0S`+(<(RAPW3g@f}&t8q`_(2^lWl@%7l zKshC3*;IYlqgR2h^n{J7e?~{{MLQ=r@((%4{ZOq4H)JI;mbt7RILs`Ja-3}-=s;cz z8NFng<)-1rh^!@=>t z;o0`Q@>^<=tLY73&9&qSxH0$MGr!*}s}cFyj$Ecx)bb@wG6X{#@(^;<1h~`@p@(c6 znOI0aT})B?JK9hxj1%s1=c(e__P3n3{%(4c{$ggiwpGW;S-OuPRvuS8sqF}v;;~wn zWL9>|)CGxf$SU@zED5TeVa)I}gY%G~C95!}c65~@nNG0<&juyuX;_5JdC2OA+J&OE zb^qi;iq_eUY;I{=T8fi5RR8r$&Z;rnewd^80b?q)@p2=-%3bn!iF=lzQPnpxt2RaN z?`g$e-_tPYod4*Y#c}xPdph25iEr0nc9s5M`)+yzcxdeOe+v44g;W1mL7!9@pPDtq zkyHd8!is$iZ6cp)J&FgtoQ13}CU&m$5W+7{Mb3?=qg3X8fT3sjyZ^z(1;nmcE8k66 ki*OZd{Z9nY2iDkV0S|7%i}W5C)!w%QJZ#{YxdawtBR--6ZB54%;FLFyDhwQBjQgYS*BH+QpQ0yPz zq2M8hW$3?Sg^~c-&YAKp0nS1jMc-^alB){&z1Oq>;5_7z5jeXEAgS3QPSc^bf}Nw zFpa@vAS<1Z`gNWh;dE}EK$%;E#p;3ie2RdkJ_q3MgDA95Z$*_&Wp02j19$SB)%R(B zXDM)s&SbroRar3>pZ>$i~C@)U5%T{VO@)^rbQK-2niMsb^3At6GTAYa= z%K$BkRJ>No^@d+_RYS<7mDil+s{iU-t&iNKnd`MEgZ-%%d#xM}!Que_m+fjK+Egy< z=bkI{h<65us!cGsDsit@;fB8!!)LRQ+s8f#n9pb)6LHn1_Wyz&t8=TKd-xx557&GA zH#SeM{{w%ub1P94F=seeSot8zEw*!4VDq2PCk6Wpd{F0;bDUcgXXq$#EhfuqF~}%m dkQUp+aiO0-sToG&v4U}Yu=4!e@`=2W>o>$)?u-Bc literal 0 HcmV?d00001 diff --git a/Addons/mckCCtrls.pas b/Addons/mckCCtrls.pas new file mode 100644 index 0000000..d6f5eb6 --- /dev/null +++ b/Addons/mckCCtrls.pas @@ -0,0 +1,895 @@ +unit mckCCtrls; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ComCtrls, ExtCtrls, mirror, mckCtrls, KOLCCtrls; + +{$I KOLDEF.INC} + +type + TKOLTrackBar = class(TKOLControl) + private + FOptions: TTrackbarOptions; + FPosition: Integer; + FRangeMin: Integer; + FSelStart: Integer; + FThumbLen: Integer; + FRangeMax: Integer; + FLineSize: Integer; + FPageSize: Integer; + FSelEnd: Integer; + FOnScroll: TOnScroll; + procedure SetOptions(const Value: TTrackbarOptions); + procedure SetPosition(const Value: Integer); + procedure SetLineSize(const Value: Integer); + procedure SetPageSize(const Value: Integer); + procedure SetRangeMax(const Value: Integer); + procedure SetRangeMin(const Value: Integer); + procedure SetSelEnd(const Value: Integer); + procedure SetSelStart(const Value: Integer); + procedure SetThumbLen(const Value: Integer); + procedure SetOnScroll(const Value: TOnScroll); + protected + function AdditionalUnits: string; override; + function TabStopByDefault: Boolean; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function SetupParams(const AName, AParent: string): string; override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string); override; + public + constructor Create(AOwner: TComponent); override; + published + property Options: TTrackbarOptions read FOptions write SetOptions; + property Position: Integer read FPosition write SetPosition; + property RangeMin: Integer read FRangeMin write SetRangeMin; + property RangeMax: Integer read FRangeMax write SetRangeMax; + property PageSize: Integer read FPageSize write SetPageSize; + property LineSize: Integer read FLineSize write SetLineSize; + property ThumbLen: Integer read FThumbLen write SetThumbLen; + property SelStart: Integer read FSelStart write SetSelStart; + property SelEnd: Integer read FSelEnd write SetSelEnd; + property OnScroll: TOnScroll read FOnScroll write SetOnScroll; + property TabStop; + property TabOrder; + end; + + { SPC CONTROLS } + + TSPCDirectoryEditBox = class(TKOLControl) + private + { Private declarations } + fPath: string; + fCaptionEmpty: string; + fTitle: string; + fNotAvailable: Boolean; + procedure SetTitle(Value: string); + procedure SetCaptionEmpty(Value: string); + procedure SetPath(Value: string); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property Path: string read fPath write SetPath; + property Title: string read fTitle write SetTitle; + property Font; + property CaptionEmpty: string read fCaptionEmpty write SetCaptionEmpty; + property OnChange; + property OnShow: Boolean read FNotAvailable; + property OnScroll: Boolean read FNotAvailable; + property OnResize: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + property OnMouseDblClk: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + end; + + TSortBy = (sbName, sbExtention); + TSPCFileListBox = class(TKOLListBox) + private + { Private declarations } + fIntegralHeight: Boolean; + fDoCase: TCase; + fPath: string; + fFilters: string; + FNotAvailable: Boolean; + fExecuteOnDblClk: Boolean; + fSortBy: TSortBy; + procedure SetPath(Value: string); + procedure SetFilters(Value: string); + procedure SetIntegralHeight(Value: Boolean); + procedure SetCase(Value: TCase); + procedure SetExecuteOnDblClk(Value: Boolean); + procedure SetSortBy(Value: TSortBy); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property SortBy: TSortBy read fSortBy write SetSortBy; + property Path: string read fPath write SetPath; + property ExecuteOnDblClk: Boolean read fExecuteOnDblClk write SetExecuteOnDblClk; + property Filters: string read fFilters write SetFilters; + property DoCase: TCase read fDoCase write SetCase; + property IntegralHeight: Boolean read fIntegralHeight write SetIntegralHeight; + property OnChange: Boolean read FNotAvailable; + property OnShow: Boolean read FNotAvailable; + property OnResize: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + // property OnMOuseDblClk: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnMeasureItem: Boolean read FNotAvailable; + property OnLeave: Boolean read FNotAvailable; + property OnKeyUp: Boolean read FNotAvailable; + property OnKeyDown: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEnter: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDropDown: Boolean read FNotAvailable; + property OnDrawItem: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnCloseUp: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + property OnChar: Boolean read FNotAvailable; + property OnScroll: Boolean read FNotAvailable; + // property Items: Boolean read FNotAvailable; + end; + + TSPCDirectoryListBox = class(TKOLListView) + private + { Private declarations } + fIntegralHeight: Boolean; + fDoIndent: Boolean; + fPath: string; + FNotAvailable: Boolean; + fFileListBox: TSPCFileListBox; + procedure SetPath(Value: string); + procedure SetIndent(Value: Boolean); + procedure SetIntegralHeight(Value: Boolean); + procedure SetFileListBox(Value: TSPCFileListBox); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property FileListBox: TSPCFileListBox read fFileListBox write SetFileListBox; + property Items: Boolean read FNotAvailable; + property ImageListState: Boolean read FNotAvailable; + property ImageListSmall: Boolean read FNotAvailable; + property ImageListNormal: Boolean read FNotAvailable; + property Path: string read fPath write SetPath; + property IntegralHeight: Boolean read fIntegralHeight write SetIntegralHeight; + property DoIndent: Boolean read fDoIndent write SetIndent; + // property OnChange: Boolean read FNotAvailable; + property OnShow: Boolean read FNotAvailable; + property OnResize: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnMeasureItem: Boolean read FNotAvailable; + property OnLeave: Boolean read FNotAvailable; + property OnKeyUp: Boolean read FNotAvailable; + property OnKeyDown: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEnter: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDropDown: Boolean read FNotAvailable; + property OnDrawItem: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnCloseUp: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + property OnChar: Boolean read FNotAvailable; + property OnScroll: Boolean read FNotAvailable; + property OnLVStateChange: Boolean read FNotAvailable; + property OnLVData: Boolean read FNotAvailable; + property OnLVDelete: Boolean read FNotAvailable; + property OnEndEditLVItem: Boolean read FNotAvailable; + property OnDeleteLVItem: Boolean read FNotAvailable; + property OnDeleteAllLVItems: Boolean read FNotAvailable; + property OnCompareLVItems: Boolean read FNotAvailable; + property OnColumnClick: Boolean read FNotAvailable; + end; + + TSPCDriveComboBox = class(TKOLComboBox) + private + { Private declarations } + fDrive: char; + FNotAvailable: Boolean; + fDirectoryListBox: TSPCDirectoryListBox; + procedure SetDrive(Value: char); + procedure SetDirectoryListBox(Value: TSPCDirectoryListBox); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property DirectoryListBox: TSPCDirectoryListBox read fDirectoryListBox write SetDirectoryListBox; + property Drive: char read fDrive write SetDrive; + property OnSelChange: Boolean read FNotAvailable; + property OnShow: Boolean read FNotAvailable; + property OnResize: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + property OnMOuseDblClk: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnMeasureItem: Boolean read FNotAvailable; + property OnLeave: Boolean read FNotAvailable; + property OnKeyUp: Boolean read FNotAvailable; + property OnKeyDown: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEnter: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDropDown: Boolean read FNotAvailable; + property OnDrawItem: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnCloseUp: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + property OnChar: Boolean read FNotAvailable; + property Items: Boolean read FNotAvailable; + end; + + TSPCFilterComboBox = class(TKOLComboBox) + private + { Private declarations } + fLines: TStrings; + FNotAvailable: Boolean; + fFileListBox: TSPCFileListBox; + // procedure SetText(Value: TStrings); + // function GetText: TStrings; + procedure SetFileListBox(Value: TSPCFileListBox); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property FileListBox: TSPCFileListBox read fFileListBox write SetFileListBox; + // property Items: Boolean read FNotAvailable; + // property Filters: TStrings read GetText write SetText; + property OnSelChange: Boolean read FNotAvailable; + property OnShow: Boolean read FNotAvailable; + property OnResize: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + property OnMOuseDblClk: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnMeasureItem: Boolean read FNotAvailable; + property OnLeave: Boolean read FNotAvailable; + property OnKeyUp: Boolean read FNotAvailable; + property OnKeyDown: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEnter: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDropDown: Boolean read FNotAvailable; + property OnDrawItem: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnCloseUp: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + property OnChar: Boolean read FNotAvailable; + end; + + TSPCStatusBar = class(TKOLControl) + private + { Private declarations } + FNotAvailable: Boolean; + fSimpleStatusText: string; + fSizeGrip: Boolean; + procedure SetSimpleStatusText(Value: string); + procedure SetSizeGrip(Value: Boolean); + protected + { Protected declarations } + function AdditionalUnits: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + public + { Public declarations } + constructor Create(Owner: TComponent); override; + published + { Published declarations } + property SizeGrip: Boolean read fSizeGrip write SetSizeGrip; + property OnShow: Boolean read FNotAvailable; + property SimpleStatusText: string read fSimpleStatusText write SetSimpleStatusText; + property Caption: Boolean read FNotAvailable; + property OnPaint: Boolean read FNotAvailable; + property OnMove: Boolean read FNotAvailable; + property OnMouseWheel: Boolean read FNotAvailable; + property OnMouseUp: Boolean read FNotAvailable; + property OnMouseMove: Boolean read FNotAvailable; + property OnMouseLeave: Boolean read FNotAvailable; + property OnMouseEnter: Boolean read FNotAvailable; + property OnMouseDown: Boolean read FNotAvailable; + property OnMOuseDblClk: Boolean read FNotAvailable; + property OnMessage: Boolean read FNotAvailable; + property OnMeasureItem: Boolean read FNotAvailable; + property OnLeave: Boolean read FNotAvailable; + property OnKeyUp: Boolean read FNotAvailable; + property OnKeyDown: Boolean read FNotAvailable; + property OnHide: Boolean read FNotAvailable; + property OnEnter: Boolean read FNotAvailable; + property OnDropFiles: Boolean read FNotAvailable; + property OnDropDown: Boolean read FNotAvailable; + property OnDrawItem: Boolean read FNotAvailable; + property OnDestroy: Boolean read FNotAvailable; + property OnEraseBkgnd: Boolean read FNotAvailable; + property OnCloseUp: Boolean read FNotAvailable; + property OnClick: Boolean read FNotAvailable; + property OnChar: Boolean read FNotAvailable; + property Items: Boolean read FNotAvailable; + end; + +procedure Register; + +(*) +{$R mckCCtrls.dcr} +(*) + +implementation + +procedure Register; +begin + RegisterComponents('KOLAddons', [TKOLTrackBar, TSPCDirectoryEditBox, + TSPCDirectoryListBox, TSPCDriveComboBox, TSPCFileListBox, TSPCFilterComboBox, + TSPCStatusBar]); +end; + +{ TKOLTrackBar } + +function TKOLTrackBar.AdditionalUnits: string; +begin + Result := ', KOLCCtrls'; +end; + +constructor TKOLTrackBar.Create(AOwner: TComponent); +begin + inherited; + Width := 200; + DefaultWidth := Width; + Height := 40; + DefaultHeight := Height; +end; + +procedure TKOLTrackBar.SetLineSize(const Value: Integer); +begin + FLineSize := Value; + Change; +end; + +procedure TKOLTrackBar.SetOnScroll(const Value: TOnScroll); +begin + FOnScroll := Value; + Change; +end; + +procedure TKOLTrackBar.SetOptions(const Value: TTrackbarOptions); +begin + FOptions := Value; + Change; +end; + +procedure TKOLTrackBar.SetPageSize(const Value: Integer); +begin + FPageSize := Value; + Change; +end; + +procedure TKOLTrackBar.SetPosition(const Value: Integer); +begin + FPosition := Value; + Change; +end; + +procedure TKOLTrackBar.SetRangeMax(const Value: Integer); +begin + FRangeMax := Value; + Change; +end; + +procedure TKOLTrackBar.SetRangeMin(const Value: Integer); +begin + FRangeMin := Value; + Change; +end; + +procedure TKOLTrackBar.SetSelEnd(const Value: Integer); +begin + FSelEnd := Value; + Change; +end; + +procedure TKOLTrackBar.SetSelStart(const Value: Integer); +begin + FSelStart := Value; + Change; +end; + +procedure TKOLTrackBar.SetThumbLen(const Value: Integer); +begin + FThumbLen := Value; + Change; +end; + +procedure TKOLTrackBar.SetupConstruct(SL: TStringList; const AName, + AParent, Prefix: string); +var + S : string; +begin + S := GenerateTransparentInits; + SL.Add(Prefix + AName + ' := PTrackbar( New' + TypeName + '( ' + + SetupParams(AName, AParent) + ' )' + S + ');'); +end; + +procedure TKOLTrackBar.SetupFirst(SL: TStringList; const AName, AParent, + Prefix: string); +begin + inherited; + if RangeMin <> 0 then + SL.Add(Prefix + AName + '.RangeMin := ' + IntToStr(RangeMin) + ';'); + if RangeMax <> 0 then + SL.Add(Prefix + AName + '.RangeMax := ' + IntToStr(RangeMax) + ';'); + if PageSize <> 0 then + SL.Add(Prefix + AName + '.PageSize := ' + IntToStr(PageSize) + ';'); + if LineSize <> 0 then + SL.Add(Prefix + AName + '.LineSize := ' + IntToStr(LineSize) + ';'); + if Position <> 0 then + SL.Add(Prefix + AName + '.Position := ' + IntToStr(Position) + ';'); + if ThumbLen <> 0 then + SL.Add(Prefix + AName + '.ThumbLen := ' + IntToStr(ThumbLen) + ';'); + if SelStart <> 0 then + SL.Add(Prefix + AName + '.SelStart := ' + IntToStr(SelStart) + ';'); + if SelEnd <> 0 then + SL.Add(Prefix + AName + '.SelEnd := ' + IntToStr(SelEnd) + ';'); +end; + +function TKOLTrackBar.SetupParams(const AName, AParent: string): string; +var + S : string; +begin + S := ''; + if trbAutoTicks in Options then S := 'trbAutoTicks,'; + if trbEnableSelRange in Options then S := S + 'trbEnableSelRange,'; + if trbFixedLength in Options then S := S + 'trbFixedLength,'; + if trbNoThumb in Options then S := S + 'trbNoThumb,'; + if trbNoTicks in Options then S := S + 'trbNoTicks,'; + if trbTooltips in Options then S := S + 'trbTooltips,'; + if trbTopLeftMarks in Options then S := S + 'trbTopLeftMarks,'; + if trbVertical in Options then S := S + 'trbVertical,'; + if trbNoBorder in Options then S := S + 'trbNoBorder,'; + S := Copy(S, 1, Length(S) - 1); + Result := AParent + ', [' + S + '], '; + if TMethod(OnScroll).Code <> nil then + Result := Result + 'Result.' + ParentForm.MethodName(TMethod(OnScroll).Code) + else + Result := Result + 'nil'; +end; + +function TKOLTrackBar.TabStopByDefault: Boolean; +begin + Result := TRUE; +end; + +{ TSPCDirectoryEditBox } + +constructor TSPCDirectoryEditBox.Create; +var + TS : string; +begin + inherited; + Width := 145; + Height := 21; + Title := 'Select folder:'; + GetDir(0, TS); + Path := TS; + Font.FontHeight := -11; + Color := $FFFFFF; +end; + +function TSPCDirectoryEditBox.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +procedure TSPCDirectoryEditBox.SetPath(Value: string); +begin + if DirectoryExists(Value) then fPath := Value else fPath := ''; + Change; +end; + +procedure TSPCDirectoryEditBox.SetCaptionEmpty(Value: string); +begin + fCaptionEmpty := Value; + Change; +end; + +procedure TSPCDirectoryEditBox.SetTitle(Value: string); +begin + fTitle := Value; + Change; +end; + +procedure TSPCDirectoryEditBox.SetupFirst; +begin + inherited; + SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';'); + SL.Add(Prefix + AName + '.Title:=''' + Title + ''';'); + SL.Add(Prefix + AName + '.CaptionEmpty:=''' + CaptionEmpty + ''';'); + SL.Add(Prefix + AName + '.Initialize;'); + SL.Add(Prefix + AName + '.Path:=''' + Path + ''';'); + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); +end; + +{ TSPCDirectoryListBox } + +procedure TSPCDirectoryListBox.SetIndent(Value: Boolean); +begin + fDoIndent := Value; + Change; +end; + +constructor TSPCDirectoryListBox.Create; +var + TS : string; +begin + inherited; + Width := 145; + Height := 105; + DoIndent := True; + GetDir(0, TS); + Path := TS; +end; + +function TSPCDirectoryListBox.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +function Boolean2Str(b: Boolean): string; +begin + if b then + Result := 'True' + else + Result := 'False'; +end; + +procedure TSPCDirectoryListBox.SetupFirst; +//var St: string; +begin + inherited; + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); + SL.Add(Prefix + AName + '.DoIndent:=' + Boolean2Str(DoIndent) + ';'); + SL.Add(Prefix + AName + '.IntegralHeight:=' + Boolean2Str(IntegralHeight) + ';'); + SL.Add(Prefix + AName + '.Path:=''' + Path + ''';'); +end; + +procedure TSPCDirectoryListBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); +begin + if Assigned(fFileListBox) then if Length(fFileListBox.Name) > 0 then SL.Add(Prefix + AName + '.FileListBox:=Result.' + fFileListBox.Name + ';'); +end; + +procedure TSPCDirectoryListBox.SetFileListBox(Value: TSPCFileListBox); +begin + fFileListBox := Value; + Change; +end; + +procedure TSPCDirectoryListBox.SetIntegralHeight(Value: Boolean); +begin + fIntegralHeight := Value; + Change; +end; + +procedure TSPCDirectoryListBox.SetPath(Value: string); +var + fT : string; +begin + fT := Value; + if Value[Length(Value)] = '\' then fT := Value else + if Length(Value) = 1 then fT := Value + ':\' else fT := Value + '\'; + if DirectoryExists(fT) then fPath := fT else fPath := ''; + Change; +end; + +{ TSPCDriveComboBox } + +constructor TSPCDriveComboBox.Create; +var + TS : string; +begin + inherited; + Width := 145; + Height := 22; + Color := clWhite; + GetDir(0, TS); + Drive := TS[1]; +end; + +function TSPCDriveComboBox.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +procedure TSPCDriveComboBox.SetupFirst; +begin + inherited; + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); + SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';'); + SL.Add(Prefix + AName + '.Drive:=''' + Drive + ''';'); +end; + +procedure TSPCDriveComboBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); +begin + if Assigned(fDirectoryListBox) then if Length(fDirectoryListBox.Name) > 0 then SL.Add(Prefix + AName + '.DirectoryListBox:=Result.' + fDirectoryListBox.Name + ';'); +end; + +procedure TSPCDriveComboBox.SetDirectoryListBox(Value: TSPCDirectoryListBox); +begin + fDirectoryListBox := Value; + Change; +end; + +procedure TSPCDriveComboBox.SetDrive; +var + fC : Char; +begin + fC := Value; + if DirectoryExists(fC + ':') then + fDrive := Value; + Change; +end; + +{ TSPCFileListBox } + +constructor TSPCFileListBox.Create; +var + TS : string; +begin + inherited; + Width := 145; + Height := 105; + Filters := '*.*'; + DoCase := ctLower; + GetDir(0, TS); + Path := TS; + Font.FontHeight := -11; +end; + +function TSPCFileListBox.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +procedure TSPCFileListBox.SetupFirst; +var + St : string; +begin + inherited; + case DoCase of + ctDefault: St := 'ctDefault'; + ctLower: St := 'ctLower'; + ctUpper: St := 'ctUpper'; + end; + SL.Add(Prefix + AName + '.DoCase:=' + St + ';'); + SL.Add(Prefix + AName + '.IntegralHeight:=' + Boolean2Str(IntegralHeight) + ';'); + SL.Add(Prefix + AName + '.Filters:=''' + Filters + ''';'); + SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';'); + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); + SL.Add(Prefix + AName + '.Path:=''' + Path + ''';'); + SL.Add(Prefix + AName + '.ExecuteOnDblClk:=' + Boolean2Str(ExecuteOnDblClk) + ';'); + case fSortBy of + sbName: SL.Add(Prefix + AName + '._SortBy:=sbName;'); + sbExtention: SL.Add(Prefix + AName + '._SortBy:=sbExtention;'); + end; +end; + +procedure TSPCFileListBox.SetCase(Value: TCase); +begin + fDoCase := Value; + Change; +end; + +procedure TSPCFileListBox.SetIntegralHeight(Value: Boolean); +begin + fIntegralHeight := Value; + Change; +end; + +procedure TSPCFileListBox.SetFilters(Value: string); +begin + fFilters := Value; + Change; +end; + +procedure TSPCFileListBox.SetPath(Value: string); +begin + if DirectoryExists(Value) then + begin + if Value[Length(Value)] = '\' then fPath := Value else fPath := Value + '\'; + end else fPath := ''; + Change; +end; + +procedure TSPCFileListBox.SetExecuteOnDblClk(Value: Boolean); +begin + fExecuteOnDblClk := Value; + Change; +end; + +procedure TSPCFileListBox.SetSortBy(Value: TSortBy); +begin + fSortBy := Value; + Change; +end; + +{ TSPCFilterComboBox } + +constructor TSPCFilterComboBox.Create; +//var +// TS: string; +begin + inherited; + Width := 145; + Height := 22; + Color := clWhite; + fLines := TStringList.Create; + Font.FontHeight := -11; +end; + +function TSPCFilterComboBox.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +procedure TSPCFilterComboBox.SetFileListBox(Value: TSPCFileListBox); +begin + fFileListBox := Value; + Change; +end; + +{procedure TSPCFilterComboBox.SetText; +begin + fLines.Text:=Value.Text; + Change; +end; + +function TSPCFilterComboBox.GetText: TStrings; +begin + Result:=fLines; +end;} + +procedure TSPCFilterComboBox.SetupFirst; +//var +// i: Integer; +begin + inherited; + if (Length(FLines.Text) > 0) then + AddLongTextField(SL, Prefix, AName + '.Text:=', FLines.Text, ';'); + SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';'); + // SL.Add( Prefix + AName + '.BuildList;'); + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); +end; + +procedure TSPCFilterComboBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); +begin + if Assigned(fFileListBox) then if Length(fFileListBox.Name) > 0 then SL.Add(Prefix + AName + '.FileListBox:=Result.' + fFileListBox.Name + ';'); +end; + +{ TSPCStatusBar } + +constructor TSPCStatusBar.Create; +//var +// TS: string; +begin + inherited; + Width := 145; + Height := 19; + Align := TKOLAlign(caBottom); +end; + +function TSPCStatusBar.AdditionalUnits; +begin + Result := ', KOLCCtrls'; +end; + +procedure TSPCStatusBar.SetupFirst; +//var +// St: string; +begin + inherited; + SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';'); + SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';'); + SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';'); + SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';'); + SL.Add(Prefix + AName + '.SimpleStatusText:=''' + SimpleStatusText + ''';'); + SL.Add(Prefix + AName + '.SizeGrip:=' + Boolean2Str(SizeGrip) + ';'); +end; + +procedure TSPCStatusBar.SetSimpleStatusText(Value: string); +begin + fSimpleStatusText := Value; + Change; +end; + +procedure TSPCStatusBar.SetSizeGrip(Value: Boolean); +begin + fSizeGrip := Value; + Change; +end; + +end. + diff --git a/Addons/mckCProgBar.dcr b/Addons/mckCProgBar.dcr new file mode 100644 index 0000000000000000000000000000000000000000..f72d0006dcf07a77446f1b82484f1ae653df886f GIT binary patch literal 2184 zcmeIyJ&x2s5QgCoL_oMHS%rIy0)!?(S_B-Rj#5Xd0CA3rIRil*VWXXZz`ULwErW&- z2_bE_AAfCo#&-Y6l4RJnh30SN_NC;U*|z8Uthc(;dwkRf-08snojy_D=r!$CZf;(^ zI5%}m!_JN@s~(h*1$8ncEgjdTPOg~qI*EF&F(M4>TjnA=E4AW>+{X$pLd zbOaKG#wh83%CPr5u-8Ikl=MH%;0PoNjak#?MmhqCLSxpHhLMgyqR^N%-8>}I5l9po zvz9^`=?EkWjakd2jdTPOg~ptgP>zv~K%&qXHT`cH9Dzh(ud|kx8R-Zl3XNII&W&^g z5{1UBB^gFK0*OLn)^bfF9f3rlF>5K8k&Zy3(3rK%+ek+sQM&)J=?lM0?#EZ;wCx`o zTA-f3JDVP!%6~8d$L+dYzV`9*V70f)Q^$wH;qd5m 0 then + BColor := TColor(Msg.lParam) else + BColor := (Parent as TForm).Color; + FColor := (Parent as TForm).Font.Color; + end; +end; + +function TColorProgressBar.AdditionalUnits; +begin + Result := ', KOLProgBar'; +end; + +procedure TColorProgressBar.SetupFirst; +var St: string; +begin + inherited; + if fPosition <> 50 then begin + SL.Add( Prefix + AName + '.Position := ' + inttostr(fPosition) + ';'); + end; + if fBorder <> 4 then begin + SL.Add( Prefix + AName + '.Border := ' + inttostr(fBorder) + ';'); + end; + if fMin <> 0 then begin + SL.Add( Prefix + AName + '.Min := ' + inttostr(fMin) + ';'); + end; + if fMax <> 100 then begin + SL.Add( Prefix + AName + '.Max := ' + inttostr(fMax) + ';'); + end; + if fFColor <> clRed then begin + SL.Add( Prefix + AName + '.FColor := ' + color2str(fFColor) + ';'); + end; + if fBColor <> clRed then begin + SL.Add( Prefix + AName + '.BColor := ' + color2str(fBColor) + ';'); + end; + if fBevel <> bvDown then begin + if fBevel = bvUp then St := 'bvUp' else St := 'bvNone'; + SL.Add( Prefix + AName + '.Bevel := ' + St + ';'); + end; +end; + +procedure TColorProgressBar.SetFColor; +begin + fFColor := C; + fFirst := True; + Paint; +end; + +procedure TColorProgressBar.SetBColor; +begin + fBColor := C; + fFirst := True; + Paint; +end; + +procedure TColorProgressBar.SetPosition; +begin + fPosition := P; + Paint; +end; + +procedure TColorProgressBar.SetBorder; +begin + fBorder := B; + fFirst := True; + Paint; +end; + +procedure TColorProgressBar.SetParentCl; +begin + fParentCl := B; + if B then begin + Perform(CM_PARENTCOLORCHANGED, 0, 0); + Paint; + end; +end; + +procedure TColorProgressBar.SetBevel; +begin + fBevel := B; + fFirst := True; + Paint; +end; + +procedure TColorProgressBar.SetMin; +begin + fMin := M; + fFirst := True; + if fMax = fMin then fMax := fMin + 1; + Paint; +end; + +procedure TColorProgressBar.SetMax; +begin + fMax := M; + fFirst := True; + if fMin = fMax then fMin := fMax - 1; + Paint; +end; + +procedure TColorProgressBar.Paint; +var Rct: TRect; + Trc: TRect; + Twk: TRect; + Str: string; + Rht: integer; + Len: integer; + Rgn: HRgn; +begin + Rct := GetClientRect; + Trc := Rct; + if (fPosition <= fOldPosit) or fFirst or + (csDesigning in ComponentState) then begin + case fBevel of + bvUp: begin + Frame3D(Canvas, Rct, clWhite, clBlack, 1); + end; +bvDown: begin + Frame3D(Canvas, Rct, clBlack, clWhite, 1); + end; + end; + + fFirst := False; + Canvas.brush.Color := fBColor; + Canvas.FillRect(Rct); + end; + Rct := Trc; + + InflateRect(Rct, -fBorder, -fBorder); + Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min); + + Str := ' ' + inttostr(fPosition * 100 div (fMax - fMin)) + '% '; + Trc.Left := (width - Canvas.TextWidth(Str)) div 2; + Trc.Right := (width + Canvas.TextWidth(Str)) div 2 + 1; + + if (Rct.Right <= Trc.Left) then begin + Canvas.brush.Color := fFColor; + Canvas.FillRect(Rct); + end else begin + Canvas.brush.Color := fFColor; + Twk := Rct; + Twk.Right := Trc.Left; + Canvas.FillRect(Twk); + end; + + Rht := Rct.Right; + Canvas.Font.Name := Font.FontName; + Canvas.Font.Height := Font.FontHeight; + Canvas.Font.Color := Font.Color; + Canvas.Font.Style := Font.FontStyle; + Len := Length(Str); + Rct.Left := (width - Canvas.TextWidth(Str)) div 2; + Rct.Right := (width + Canvas.TextWidth(Str)) div 2 + 1; + + if (fStr <> Str) or ffirst or (csDesigning in ComponentState) then begin + if (Rct.Right > Rht) or (Canvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin + Rgn := CreateRectRgn({Left +} Rht, {Top +} Rct.Top, {Left +} Rct.Right, {Top +} Rct.Bottom); + SelectClipRgn(Canvas.Handle, Rgn); + Canvas.brush.Color := fBColor; + SetTextColor(Canvas.Handle, ColorToRGB(fFColor)); + DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP {or DT_NOCLIP}); + SelectClipRgn(Canvas.Handle, 0); + DeleteObject(Rgn); + end; + end; + + if Rht < Rct.Right then begin + Rct.Right := Rht; + end; + + Dec(Rct.Left); + Inc(Rct.Right); + + if (Rct.Right > Rct.Left) then begin + Canvas.brush.Color := fFColor; + SetTextColor(Canvas.Handle, ColorToRGB(fBColor)); + DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP); + if Rct.Right < Trc.Right then begin + Twk := Rct; + Twk.Top := Twk.Top + Canvas.TextHeight(Str); + Canvas.Fillrect(Twk); + end; + end; + + if (Rct.Right >= Trc.Right) then begin + Canvas.brush.Color := fFColor; + Rct.Left := Trc.Right - 1; + Rct.Right := Rht; + Canvas.FillRect(Rct); + end; + + fStr := Str; + fOldPosit := fPosition; +end; + +end. diff --git a/Addons/mckEcmListEdit.dcr b/Addons/mckEcmListEdit.dcr new file mode 100644 index 0000000000000000000000000000000000000000..0ae917f0090d38fe33be265bc6fd9d17a118c5d2 GIT binary patch literal 484 zcma)$F>V4e5Jf+Tg2q}(=qS@~8&@#}3TTUP7ph1u-R)s0Eu=ldN+~F;xkGL+eB)gd zBqH(UnR)sij|TwO4Am0E2ZagnPDgc$13uAUhYdckXWin9-Ug0z7+x(FtJyf=CNey_uH!{sFc&R_x$La?sjZ0g#u!M7r@FSLCz@nqjMj+ZN%5Sb z?Q!EX+p^CdK1@k^5{QGcJL)fI?{XaUEy8t*$n#3IRn=c|Rk@~huF3qwcmMb=_mAJ= PHa~ nil then +// SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnGetEditText := Result.' + + inherited; +end; + +procedure TKOLEcmListEdit.SetupLast; +begin + inherited AssignEvents(SL, AName); + if @fOnGetText <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnGetEditText := Result.' + + ParentForm.MethodName( @OnGetEditText ) + ';' ); + if @fOnPutText <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnPutEditText := Result.' + + ParentForm.MethodName( @OnPutEditText ) + ';' ); + if @fOnEndEdit <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnStopEdit := Result.' + + ParentForm.MethodName( @OnStopEdit ) + ';' ); + if @fOnColAdjust <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnColAdjust := Result.' + + ParentForm.MethodName( @OnColAdjust ) + ';' ); + if @fOnEditChar <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnEditChar := Result.' + + ParentForm.MethodName( @OnEditChar ) + ';' ); + if @fOnCreateEdit <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnCreateEdit := Result.' + + ParentForm.MethodName( @OnCreateEdit ) + ';' ); + if @fOnDrawCell <> nil then + SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnDrawCell := Result.' + + ParentForm.MethodName( @OnDrawCell ) + ';' ); +end; + +procedure TKOLEcmListEdit.AssignEvents; +begin + inherited; +end; + +function TKOLEcmListEdit.GetCaption; +begin + Result := inherited Caption; +end; + +function TKOLEcmListEdit.GetStyle; +begin +// Result := lvsDetail; + Result := fLimStyle; +end; + +function TKOLEcmListEdit.GetOptions; +begin + Result := inherited Options; +end; + +procedure TKOLEcmListEdit.SetOptions; +begin + inherited Options := v + [{lvoRowSelect,}lvoHideSel,lvoOwnerDrawFixed]; +end; + +procedure Register; +begin + RegisterComponents('KOLAddons', [TKOLEcmListEdit]); + RegisterComponentEditor( TKOLEcmListEdit, TKOLLVColumnsEditor ); +end; + +procedure TKOLEcmListEdit.UpdateColumns; +begin + Change; +end; + +procedure TKOLEcmListEdit.SetOnGetText(const Value: TOnEditText); +begin + if @fOnGetText <> @Value then begin + fOnGetText := Value; + Change(); + end; +end; + +procedure TKOLEcmListEdit.SetOnPutText(const Value: TOnEditText); +begin + if @fOnPutText <> @Value then begin + fOnPutText := Value; + Change(); + end; +end; + +procedure TKOLEcmListEdit.SetOnEndEdit(const Value: TOnEndEdit); +begin + if @fOnEndEdit <> @Value then begin + fOnEndEdit := Value; + Change(); + end; +end; + +procedure TKOLEcmListEdit.SetOnColAdjust(const Value: TOnColAdjust); +begin + if @fOnColAdjust <> @Value then begin + fOnColAdjust := Value; + Change; + end; +end; + +procedure TKOLEcmListEdit.SetOnEditChar(const Value: TOnEditChar); +begin + if @fOnEditChar <> @Value then begin + fOnEditChar := Value; + Change(); + end; +end; + +procedure TKOLEcmListEdit.SetOnDrawCell(const Value: TOnDrawCell); +begin + if @FOnDrawCell <> @Value then begin + FOnDrawCell:= Value; + Change(); + end; +end; + +function TKOLEcmListEdit.SetupParams(const AName, AParent: String): String; +begin + Result := inherited SetupParams(AName,AParent) +end; + +procedure TKOLEcmListEdit.SetOnCreateEdit(const Value: TOnCreateEdit); +begin + if @fOnCreateEdit <> @Value then begin + fOnCreateEdit := Value; + Change(); + end; +end; + + +procedure TKOLEcmListEdit.SetLimStyle(const Value: TKOLListViewStyle); +begin + if (Value <> fLimStyle) and ((Value = lvsDetail) or (Value = lvsDetailNoHeader)) then begin + fLimStyle := Value; + inherited Style := fLimStyle; + end; +end; + +end. + diff --git a/Addons/mckHTTP.dcr b/Addons/mckHTTP.dcr new file mode 100644 index 0000000000000000000000000000000000000000..8846469d2ce8bc7cc73945e4fbd69827afcce8a9 GIT binary patch literal 696 zcmb`Cu};J=42I3o5vjMb-N=Y!#*=Pn1|%Yt;U0p==y+Qn;a;UuGDc$IK{9kGlldK| z6-Z17tBLLZ`<{11^oTy)>gX~`irA>*=$ScP^OMIF5fz$$D8 z#l_)^!7zj-zUx56%XsJO73K#I%B@?*>{F+`3K~r`epTTz=9G+oUSYXNlPZ_oR?Mt( zqylhC);kq)*!mfQG#pb5#Xq}_GBbGcIxjBpEi-j '' then + SL.Add( Prefix + AName + '.UserName := ''' + fUserName + ''';'); + if fUserPass <> '' then + SL.Add( Prefix + AName + '.Password := ''' + fUserPass + ''';'); + if fHostAddr <> '' then + SL.Add( Prefix + AName + '.Url := ''' + fHostAddr + ''';'); + if fHostPort <> '80' then + SL.Add( Prefix + AName + '.HostPort := ' + fHostPort + ';'); + if fProxyAdr <> '' then + SL.Add( Prefix + AName + '.ProxyAddr := ''' + fProxyAdr + ''';'); + if fProxyPrt <> '' then + SL.Add( Prefix + AName + '.ProxyPort := ' + fProxyPrt + ';'); +end; + +procedure TKOLHttp.SetupLast(SL: TStringList; const AName, + AParent, Prefix: String); +begin + // +end; + +procedure TKOLHttp.AssignEvents(SL: TStringList; const AName: String); +begin + inherited; + DoAssignEvents( SL, AName, + [ 'OnClose' ], + [ @OnClose ]); +end; + +procedure Register; +begin + RegisterComponents('KOLAddons', [TKOLHttp]); +end; + +end. + diff --git a/Addons/mckHTTPDownload.dcr b/Addons/mckHTTPDownload.dcr new file mode 100644 index 0000000000000000000000000000000000000000..d1301017426b543b7909937337ba7a2f80eb9bec GIT binary patch literal 1736 zcmZ|Py>8S%5Ww*vK?rv#q1%%7-e8a@kU)eY677^cgR6NDH&Y<0dx)v2u04rjAHYSL ztFAEr^_~-j!1{ik^~|2vA1jN96f8?e_euNyN<_&l%az>8C%Ki+@{!)1e3cIzeUmR_ zZsk2kTf4b=`*Q2Qqx0tCg}h$VdbL&mjxNGa+*pIofMK%oQ@wO^zb zqQc+^B&vuB3KSfeBao<1vDwLoET1QJzL zxJ)T%o52xCRM8?RP#7G6MD4fDAXSCI5lGbjNURVQ21g)K`{VLLR2UqAMD33<3Q=Kj z1QNAB<}5^o!4XK*^%ZC>M1{c-NK|p|-=(14xuI==L>1@$y%Z=6jzFUJ*QSN2FgOB< z+Fz*^qQc+^Bx--%OyaIEI0A{+-rgCmfrlH7kv zfx_Sjw5|4~RSHpIa0C*yFFP$ng~1U>)V?IG5ETYTAW{2r^+Hq_9DzjbOF0TrVQ>Tz zwJ-B5M1{c-a(`ar2jiUc@fBHr?PEg^Z0mQY#s9Qx+GA-x%$I{Rt<~1*@o?M<=j)}F zC{ELKI3Bk`OU+Zu4|7Xzh4XotreV$Z^j28r=`@_#wlsx-$r-)2$8`V4Lz?P({&mM$ zF2fIp?H}|G%OyPw<9N7?KTPfPefT`=p68FlahP_yXXE$dZZ{6Yv;3Og|0_T4#*zHx z(k}C!#@3j3YwM$)hn^qD(>i<{+wgXwTb`+DyIs#O`zQI+mR^>bNn2y^X?#p?g?5rB WX$t#xU$p)9+SjSuZf@=2X!!$NGR<-T literal 0 HcmV?d00001 diff --git a/Addons/mckHashs.dcr b/Addons/mckHashs.dcr new file mode 100644 index 0000000000000000000000000000000000000000..12c9feceb747f741b6d279f89146db14c7d25b91 GIT binary patch literal 4444 zcmds)!EO^V5Qe9Shk#p;95~QIDy~Q%KolXBis#9Z$I1h&{3I*y8`ymRjJ-+IHbs>p zZR^cu|2X4uI^X_Y*Uapcv(`9~H`?D5vv>5=`oga5hyAik`(~f)59j3^`TAv-ZxFBA zd1BFhN{+kR+KiX2*Ky$;$+@=8X2TcyQM%N)@E*TY*CV$=s}paz){&MIZ^PtTpU2kk zdLm}vAYzp6?Uq&+PWmG|GaTpd5VyBpx-GY#_Srtr7wtJRtEFaY%d3vln1@tLYMP>F z*I5Aa07`L^PTt?Nk4=O33r*zlG-UVu3OPo*kJ+jtv**i9*m|wO7Fx{QPtI&A&0DaU zWW||ZR(xaT+SwOp+?ZwcAEAkvJhi(%UYVSBX6N>CCTELfm#0GUy*y<|UDfe^<99A+B&#ab5*u+fyE6?NjuXqH_fQs7(TW<%VxK~FZt~| zld}$u>r%NraAO|$+HY}OglXL#jv1en5IN~dwWEbLT%E9)JI!N)y{PkyB!EtmXsnXU zu5R7~zvOXW-Q~I9c5W-XcmnKrl3=@{^6-Sw9)l9nsBT}kDupbnt%9a;8Y!+~it4Oo zwd-6Gm1Zmf0_9&&ebzDWXCh~Jy5p3^64+9zt-^TghUS>||VnKgHfg5x(ci&kV! z`ycIocJF!8ZFiQ-^<4w!We#w$7DhcmKowd&gQ?&a-yimVua(CGR^gGyb-OWQOaD~Z zt$e4lHQrL!OtH(dMyom2b6$DmMwk1Xoir~RcR0c!$#Lvi+&gldm-CKkKgTyM47Ub~S@rDmSrsWYbnL4sf#4>W~>(zWApt`9E&^n%g4jzVQBhD+ar^ MgP5Kj^2ccZ00(-~Q2+n{ literal 0 HcmV?d00001 diff --git a/Addons/mckHashs.pas b/Addons/mckHashs.pas new file mode 100644 index 0000000..3f4d086 --- /dev/null +++ b/Addons/mckHashs.pas @@ -0,0 +1,920 @@ +unit mckHashs; + +interface + +uses + Windows, Messages, Classes, Controls, mirror, mckCtrls, KOL, Graphics; + +type + + TKOLHAVAL = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLMD4 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLMD5 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLRMD128 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLRMD160 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLSHA1 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLSHA256 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLSHA384 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLSHA512 = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + + TKOLTIGER = class(TKOLObj) + private + + // fOnMyEvent: TOnMyEvent; + // procedure SetOnMyEvent(Value: TOnMyEvent); + + protected + function AdditionalUnits: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + + public + constructor Create(Owner: TComponent); override; + function TypeName: string; override; + + published + + // property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent; + + end; + +procedure Register; + +{$R *.dcr} + +implementation + +procedure Register; +begin + RegisterComponents('KOL HASHES', [TKOLHAVAL, TKOLMD4, TKOLMD5, TKOLRMD128, + TKOLRMD160, TKOLSHA1, TKOLSHA256, TKOLSHA384, TKOLSHA512, TKOLTIGER]); +end; + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLHAVAL.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLHAVAL.TypeName: string; +begin + Result := 'TKOLHAVAL'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLHAVAL.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLHAVAL.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewHAVAL;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLHAVAL.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLHAVAL.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLHAVAL.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLMD4.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLMD4.TypeName: string; +begin + Result := 'TKOLMD4'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLMD4.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLMD4.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewMD4;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLMD4.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLMD4.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLMD4.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLMD5.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLMD5.TypeName: string; +begin + Result := 'TKOLMD5'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLMD5.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLMD5.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewMD5;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLMD5.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLMD5.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLMD5.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLRMD128.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLRMD128.TypeName: string; +begin + Result := 'TKOLRMD128'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLRMD128.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLRMD128.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewRMD128;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLRMD128.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLRMD128.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLRMD128.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLRMD160.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLRMD160.TypeName: string; +begin + Result := 'TKOLRMD160'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLRMD160.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLRMD160.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewRMD160;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLRMD160.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLRMD160.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLRMD160.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLSHA1.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLSHA1.TypeName: string; +begin + Result := 'TKOLSHA1'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLSHA1.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA1.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewSHA1;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA1.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLSHA1.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLSHA1.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLSHA256.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLSHA256.TypeName: string; +begin + Result := 'TKOLSHA256'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLSHA256.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA256.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewSHA256;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA256.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLSHA256.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLSHA256.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLSHA384.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLSHA384.TypeName: string; +begin + Result := 'TKOLSHA384'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLSHA384.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA384.SetupFirst; + +begin + SL.Add(Prefix + AName + ' := NewSHA384;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA384.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLSHA384.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLSHA384.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLSHA512.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLSHA512.TypeName: string; +begin + Result := 'TKOLSHA512'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLSHA512.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA512.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewSHA512;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLSHA512.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLSHA512.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLSHA512.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +{ ДОБАВЛЕНИЕ МОДУЛЯ } + +function TKOLTIGER.AdditionalUnits; +begin + Result := ', KOLHashs'; +end; + +function TKOLTIGER.TypeName: string; +begin + Result := 'TKOLTIGER'; +end; +//////////////////////////////////////////////////////////////////////////////// + +{--------------------------} +{ РЕГИСТРАЦИЯ ОБРАБОТЧИКОВ } +{--------------------------} + +procedure TKOLTIGER.AssignEvents; +begin + inherited; + // DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]); + // DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLTIGER.SetupFirst; +//const +// spc = ', '; +// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE'); + +begin + SL.Add(Prefix + AName + ' := NewTIGER;'); + + // Boolean2Str[TRUE] + // Color2Str(myColor) + // SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';'); +end; + +{--------------------------} +{ ДОБАВЛЕНИЕ В unitX_X.inc } +{--------------------------} + +procedure TKOLTIGER.SetupLast; +begin + // SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';'); +end; +//////////////////////////////////////////////////////////////////////////////// + +{-------------} +{ КОНСТРУКТОР } +{-------------} + +constructor TKOLTIGER.Create; +begin + inherited; + + // fmyInt := 10; +end; + +{ procedure TKOLTIGER.SetOnMyEvent; +begin +fOnMyEvent := Value; +Change; +end; } + +end. +