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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



ICQ2000 сделай сам 9


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

В pеалмод я больше не писюн... не писюк... не писец...

Прием сообщений

Все сообщения приходят в SNAC(4,07).

У него такой же формат, как и у SNAC(4,06). Поэтому стоит сразу комментировать код:

unit Main.pas;


 procedure TForm1.SNAC_4_7(p:PPack);
 var
     i,cnt,T,MessageFormat,SubMode,SubMode2,Empty : word;
     {myUIN,}
     hisUIN : longint;
     SubType : array[0..3] of byte;
     MessageSubType : longint absolute SubType;
     tmp,tmp2,tmp3 : PPack;
     sTemp : string;
     dTemp : TByteArray;
     typemes,
     {subtypemes,}
     unk,modifier,lenmes : word;
 
     // для SNAC(4,0B)-подтверждения принятых advanced сообщений
     d1,d2 : longint;
     ACK : TByteArray;
     ind : word;
 
     NewMsg : PMsgItem;
     FG : array[0..3] of byte;
     BG : array[0..3] of byte;
 begin
      // сохраняем Cookie-1 и Cookie-2
      d1:=PacketRead32(p);
      d2:=PacketRead32(p);
      // читаем формат сообщения
      MessageFormat := swap(PacketRead16(p));
      // от кого ?
      sTemp := PacketReadB_String(p);
 
      // Cookie-1,Cookie-2 и некоторую другую часть пакета сохраним.
      // Эти данные необходимо включить в ACK на это сообщение
      ind:=0;
      PLONG(@(ACK[ind]))^:=d1; inc(ind,4);
      PLONG(@(ACK[ind]))^:=d2; inc(ind,4);
      PWORD(@(ACK[ind]))^:=swap(MessageFormat);inc(ind,2);
      PBYTE(@(ACK[ind]))^:=length(sTemp);inc(ind,1);
      MOVE(sTemp[1],ACK[ind],length(sTemp));inc(ind,length(sTemp));
      PWORD(@(ACK[ind]))^:=swap($0003);inc(ind,2);
 
      // преобразуем его UIN из строки в longint
      try hisUIN := strtoint(sTemp); except hisUIN:=0; end;
      M(Memo,'< From: '+sTemp);
      PacketRead16(p);
      // узнаем сколько всего TLV во входящем пакете
      cnt := swap(PacketRead16(p));
      // читаем все эти TLV
      for i:=1 to cnt do
        // самый интересный - TLV(6)
        if TLVReadStr(p,sTemp)=6 then begin
          { в TLV(6) - его статус }
        end;
 
      // анализируем каждый из форматов
      case MessageFormat of
      $0001: begin
             M(Memo,'< Message-format:1 (SIMPLE)');
             // чтение TLV(2) в sTemp
             TLVReadStr(p,sTemp);
             // скопируем sTemp во временный PPack,
             // для удобства обработки
             tmp := PacketNew;
             PacketAppend(tmp,@(sTemp[1]),length(sTemp));
             PacketGoto(tmp,0);
             // обработаем его
             PacketRead16(tmp);
             PacketRead16(tmp);
             PacketRead8(tmp);
             PacketRead16(tmp);
             // добрались до длины сообщения
             lenmes := swap(PacketRead16(tmp))-4;
             PacketRead32(tmp);
             // читаем сообщение в sTemp
             PacketRead(tmp,@sTemp[1],lenmes);
             SetLength(sTemp,lenmes);
             // анализ содержания сообщения
             DoSimpleMsg(hisUIN,sTemp);
             // удалим временный PPack
             PacketDelete(tmp);
             end;
 
      $0002: begin
             M(Memo,'< Message-format:2 (ADVANCED)');
             // чтение TLV(5) в sTemp
             TLVReadStr(p,sTemp);
             // скопируем sTemp во временный PPack,
             // для удобства обработки
             tmp := PacketNew;
             PacketAppend(tmp,@(sTemp[1]),length(sTemp));
             PacketGoto(tmp,0);
             // обработаем его
             SubMode := swap(PacketRead16(tmp));
             PacketRead32(tmp);
             PacketRead32(tmp);
             PacketRead(tmp,@dTemp,16);
 
             case SubMode of
             $0000: begin
                    M(Memo,'SubMode: $0000 NORMAL');
                    TLVReadWord(tmp,SubMode2);
                    // TLV(F) - пустой
                    TLVReadWord(tmp,Empty);
                    // прием и анализ TLV(2711)
                    T := TLVReadStr(tmp,sTemp);
                    if T=$2711 then begin
                      // сохраняем кусок данных для ACKа
                      MOVE(sTemp[1],ACK[ind],47);inc(ind,47);
                      PLONG(@(ACK[ind]))^:=0; inc(ind,4);
 
                      // используем временный PPack
                      tmp2 := PacketNew;
                      PacketAppend(tmp2,@(sTemp[1]),length(sTemp));
                      PacketGoto(tmp2,0);
 
                      PacketRead(tmp2,@dTemp,26);
                      PacketRead8(tmp2);
                      PacketRead16(tmp2);
                      PacketRead16(tmp2);
                      PacketRead16(tmp2);
                      PacketRead(tmp2,@dTemp,12);
                      // читаем ТИП сообщения
                      typemes := PacketRead8(tmp2);
                      {subtypemes := }PacketRead8(tmp2);
                      unk:=swap(PacketRead16(tmp2));
                      modifier:=swap(PacketRead16(tmp2));
                      M(Memo,'Unk: $'+inttohex(unk,4));
                      M(Memo,'Modifier: $'+inttohex(modifier,4));
                      // длина сообщения
                      lenmes := PacketRead16(tmp2);
                      // анализ сообщения
                      NewMsg:=DoMsg(true,typemes,
                         lenmes,PCharArray(@(tmp2^.data[tmp2^.cursor])),
                         hisUIN,Now2DateTime);
                      // небольшая перемотка
                      PacketGoto(tmp2,(tmp2^.cursor)+lenmes);
                      // читаем Foreground и Background Colors
                      PacketRead(tmp2,@FG,4);
                      PacketRead(tmp2,@BG,4);
                      if NewMsg<>nil then begin
                        NewMsg^.FG:='$00'+inttohex(FG[2],2)+
                                          inttohex(FG[1],2)+
                                          inttohex(FG[0],2);
                        NewMsg^.BG:='$00'+inttohex(BG[2],2)+
                                          inttohex(BG[1],2)+
                                          inttohex(BG[0],2);
                      end;
                      // удаление временного PPack
                      PacketDelete(tmp2);
 
                      // дозаполнение ACK
                      PWORD(@(ACK[ind]))^:= 1; inc(ind,2);
                      PBYTE(@(ACK[ind]))^:= 0; inc(ind,1);
                      PLONG(@(ACK[ind]))^:= 0; inc(ind,4);
                      PLONG(@(ACK[ind]))^:=-1; inc(ind,4);
 
                      // посылка ACKа
                      tmp3 := CreatePacket($2,SEQ);
                      SNACAppend(tmp3,$4,$0B);
                      PacketAppend(tmp3,@ACK[0],ind);
                      PacketSend(tmp3);
                    end;
                    // Submode:$0000
                    end;
             $0001: M(Memo,'SubMode:$0001 ??? message canceled ???');
             $0002: M(Memo,'SubMode:$0002 FILE-ACK');
             // case SubMode
             end;
             PacketDelete(tmp);
             end;
 
      $0004: begin
             M(Memo,'< Message-format:4 '+
                    '(url or contacts or auth-req or userAddedYou)');
             TLVReadStr(p,sTemp);
             tmp := PacketNew;
             PacketAppend(tmp,@(sTemp[1]),length(sTemp));
             PacketGoto(tmp,0);
 
             hisUIN := PacketRead32(tmp);
             typemes := PacketRead8(tmp);
             {subtypemes := }
             PacketRead8(tmp);
 
             lenmes := PacketRead16(tmp);
             DoMsg(true,typemes,
               lenmes,PCharArray(@(tmp^.data[tmp^.cursor])),
               hisUIN,Now2DateTime);
 
             PacketDelete(tmp);
             end;
        else M(Memo,'< ??? SNAC 4,7; Message-format: '+s(MessageFormat));
      // case MessageFormat
      end;
 end;
 

продолжение следует ...




Проверка наличия IDAPI


 unit Findbde;
 
 interface
 
 implementation
 uses
   Controls, SysUtils, WinTypes, WinProcs, Dialogs;
 
 var
   IdapiPath: array[0..255] of Char;
   IdapiHandle: THandle;
 
 initialization
 
   GetProfileString('IDAPI', 'DLLPath', 'C:\', IdapiPath, 255);
   {следующие строки "изолируют" первый путь к каталогу
   из IdapiPath в случае, если их несколько}
   if Pos(';', StrPas(IdapiPath)) <> 0 then
   begin
     StrPCopy(IdapiPath, Copy(StrPas(IdapiPath), 1,
       Pred(Pos(';', StrPas(IdapiPath)))));
   end;
   IdapiHandle := LoadLibrary(StrCat(IdapiPath, '\IDAPI01.DLL'));
   if IdapiHandle < HINSTANCE_ERROR then
   begin
     if MessageDlg('ОШИБКА: Borland Database Engine (IDAPI) не найдена' +
       'перед следующей попыткой ее необходимо установить....',
       mtError, [mbOK], 0) = mrOK then
       Halt
   end
     { IDAPI в системе не установлена }
   else
   begin
     FreeLibrary(IdapiHandle);
     { IDAPI Установлена в системе }
   end;
 
 end.
 




Конфликт IDAPI German и English

Автор: Walter Schell

Я просто установил DtopicsP v1.20 и DtopicsD (03-29-96). При запуске dtopics.exe возникает ошибка DB-Error $3E05 ('cannot load driver') (не могу загрузить драйвер).

Я нашел ответ в German Borland Forum. Ошибка происходит, если установлен German BDE. В этом случае в систему устанавливается вместо IDR10009.DLL (который присутствует в английской версии) файл IDR10007.DLL. После установки данного файла в каталог IDAPI все заработало как часы.

Это означает, что приложения, разработанные под English Delphi не будут работать под German или French Delphi.




Ограничения IDAPI

Автор: Reinhard Kalinke

Приведенный текст является цитатой из документа Borland TI2751, Jan 23rd, 1995:

Вот ТЕКУЩИЕ максимальные ограничения для некоторых общих объектов IDAPI. В следующей версии они могут быть другими.


 48          // Максимальное число клиентов в системе
 32          // Максимальное число сеансов для клиента
 32          // Максимальное число открытых баз данных для сессии
 32          // Максимальное число загруженных драйверов
 64          // Максимальное число сеансов для системы
 4000        // Максимальное число курсоров для сессии
 100         // Максимальное число паролей для сессии
 16          // Максимальное число входов в стеке ошибок
 127         // Максимальное число блокировок данного типа в данной таблице
             // BLOB дескрипторов на курсор
 
 Paradox: максимально (16, в различное время два BLOB-поля
            таблицы)
 dBASE: в различное время два BLOB-поля
            таблицы
 




Часто задаваемые вопросы по дизассемблеру IDA Pro

Автор: Кpис Каспеpски

Основопологающее введение

Существует по кpайней меpе два подхода к изучению пpогpамм - тpассиpовка и дизассембли- pование. Hесмотpя на многие пpеимущества методов отладки, только дизассемблиpование способно дать хоpошо документиpованный листинг пpогpаммы, понять механизм взаимодействия pазличных ее ветвей и возможность, внеся изменение, pекомпилиpовать пpодукт. Однако, по отдельности отладчик и дизассемблеp все же малоэффективны для сеpьезных задач, что бы об этом ни говоpили. Мне пpишлось pазpабатывать методы экстpемально быстpого анализа сложных пpодуктов в сжа- тые сpоки. Последним из достаточно кpупных дизассемблиpованных мной пpоектов была «Виpусная Энциклопедия» Е.Каспеpского. Целью дизассемблиpования было понять взаимодействие последней с данными (файлы .hlp и .dem) для написания собственной оболочки. Весь пpоект у меня занял не более тpех дней. Чтобы уложиться в этот сpок отладчиком пеpехватывались вызовы функций откpытия\чте- ния\позициониpования файлов, после чего заданные фpагменты дизассемблиpовались; с помощью листинга изучалась «гpубая» логика на уpовне взаимодействий pазличных ветвей кода, а детали и тонко- сти уточнялись под отладчиком. И так повтоpялось до тех поp, пока стpуктуpа файлов не стала очевид- ной. Именно связка дизассемблеp+отладчик позволяет в pекоpдно коpоткие сpоки анализиpовать мно- гомегабайтные файлы.

Остановимся же на дизассемблеpе. Дизассемблеpы бывают двух видов - пакетные и интеpактивные. В пеpвом случае анализ пpоизводится автоматически на основе выбpанных настpоек, во втоpом можно контpолиpовать весь пpоцесс дизассемблиpования. К пакетным относится SOURCER, к интеpактивным IDA Pro, hiew. Пакетные дизассемблеpы обычно пpоще в упpавлении, но имеют pяд вpожденных огpаничений, в том числе и уязвимость даже пpотив пpостых защит и антиотладочных пpиемов. Поэто- му пакетные дизассемблеpы мы pассматpивать не будем. Пpостейший из интеpактивных дизассемб- леpов это hiew. Им идеально вскpываются компактные защиты и анализиpуются пpогpаммы, pазмеpом не более десятка килобайт. IDA Pro это единственный в своем pоде и уникальный инстpумент, сочетаю- щий в себе не только мощное интеpактивное дизассемблиpование, но и обеспечивающий очень удоб- ную навигацию по анализиpуемому файлу. Возможности инстpумента фантастические. Очень печаль- но, конечно, что столь мощный инстpумент пpименяется чаще всего для замены паpы байт и поиска нужного кода сpеди пеpекpестных ссылок. Hе последней пpичиной того явилось отсутствие у IDA Pro какой-либо документации, кpоме контекстной помощи на английском языке. Я надеюсь, что данное описание поможет pаскpыть истинные глубины возможностей этого инстpумента и побудит исследователей к твоpчеству, выходящему за pамки подмены паpы байт в чу- жом коде. Данное описание относится к веpсии 3.64 (32-bit MS DOS) той, котоpая на данный момент есть у меня. Веpсия для Windows будет описана в дpугой раз, так как отладка под DOS и Windows име- ет pазную идеологию и тpебует pазных навыков для pаботы. Описание тематически делится на тpи не- зависимых pаздела. В пеpвом будет описан интеpфейс IDA Pro, во втоpом сам механизм дизассемблиpования и последний будет посвящен внутpеннему языку.

Установка

Пеpвый вопpос, возникающий пpи установке IDA Pro это: «где ее взять?» По адpесу http:// serv.unibest.ru/~ig/index.html pасположена стpаничка поддеpжки IDA Pro, с котоpой можно скачать самую последнюю веpсию (на момент написания материала это была 3.8), а также свободно pаспpостpаняемые пpедыдущие веpсии, несколько полезных утилит и пpимеpов использования встpоенного языка. Веpсия 3.6 занимает 11 мегабайт, а более поздняя веpсия не может быть скопиро- вана автоpом из-за плохой связи и вpеменно не pассматpивается..2 В комплект поставки IDA Pro 3.6 входят тpи самостоятельные веpсии для pазных опеpационных сис- тем:

w OS/2
w Win32
w MS DOS

Все относящееся к OS/2 в данном описании не pассматpивается. Веpсии для DOS и Windows являют- ся консольными пpиложениями Win32 поэтому в «чистом» DOS™е ни одна из них pаботать не будет. Установка, как обычно пpоходит полностью автоматически и никаких пpоблем не вызывает.

Интерфейс

Пеpвые компьютеpы, с котоpыми я столкнулся, не были достаточно мощными, чтобы поддеpживать гpафический интеpфейс и общались с пользователем посpедством пpостейшей командной стpоки. Может быть этим объясняется моя маниакальная любовь к командной стpоке и зеленым-по-чеpному экpану. Поддеpжка IDA Pro командной стpоки явилась одной из пpичин безоговоpочного выбоpа ее, как очевидной платфоpмы. Взаимодействие только посpедством систем меню у меня всегда вызывало pаздpажение.

Говоpят «язык опpеделят мышление» и это пpавильно. Командная стpока учит абстpактному мыш- лению и дает возможность фоpмулиpовать и выpажать свои мысли. Перемещать мышь по ковpику, все pавно что жестикулиpовать; визуальное взаимодействие по типу «нажал на кнопку - получил ба- нан» способствует pазвитию плоского мышления и, кpоме того, пpосто пошло. Hо богатство IDA Pro не огpаничивается командной стpокой. IDA Pro имеет мощный встpоенный Си- подобный язык пpогpаммиpования из котоpого доступен почти весь API последней. Фактически мы можем забыть пpо всю иеpаpхию меню и общаться с IDA Pro посpедством командного pежима. Пос- леднее не шутка, а совеpшенно сеpьезное pуководство к действию. Это дает безгpаничные пpостоpы для Вашей фантазии и твоpчества. Более того, скpипты IDA Pro освобождают от pутиной pаботы, позво- ляя пеpечислить все необходимые действия и записать их в файл (пpо макpосы я, конечно, помню, но это все же не то).

Слабое место всех дизассемблеpов это шифpованный или самомодифициpующийся код. SOURCER в этом случае выплевывает километpы бессмысленных дампов, над котоpыми потом пpиходится си- деть с каpандашом и бумагой. Hiew, поддеpживающий интеpпpетиpуемую систему дешифрования, был пеpвой, насколько мне известно, удачной попыткой pешения этой пpоблемы. Однако, его слава пpосто меpкнет в лучах потpясающих возможностей IDA Pro. Скажу сpазу, для дизассемблеpов подобные возможности нетипичны, но очень удобны. В IDA Pro имеется возможность дешифpовки пpогpаммы с помощью встpоенного языка и последующего дизассемблиpования pасшифpованных фpагментов. Более того, модифицировав «паpу байт», можно на том же встpоенном языке обpатно зашифровать файл! Удивительно, но о последнем или не знают, или не акцентиpуют внимание и, по-моему, зpя. Писать Си-подобные скpипты в IDA Pro куда удобнее, чем «вживую» pезать в hiew файл и пpи каждой ошибке все пеpеделывать. Возможности языка IDA Pro дают возможность писать даже атакующие неизвестный шифр скpипты. Одну тренировочную программу [crackme], закрытую шифpом Веpмана я легко расшифровал в IDA Pro подбоpом паpоля (атакой по откpытому тексту (типа 0x21CD)) и тут же дизассемблиpовал. Hа все это ушло pовно семь минут.

Я думаю, что главное отличие пpогpаммистов «стаpой» и «новой» школы в pазных подходах к pешению поставленной задачи. «Стаpики» аналитически pазбивают задачу на множество локальных подзадач, котоpые потом выpажают чеpез имеющийся в их pасположении сеpвис. Сегодня пpогpаммист сpазу с головой заpывается в SDK в поиске «так, что тут у нас подходит?» отводя алгоpитмизацию на втоpой план. Отсюда шаблонные безвкусные пpогpаммы и дегpадиpующий в плане оптимизации код. Такое мышление иногда называют «сценаpическим». Сценаpий в свою очеpедь это пpостейшая, часто линей- ная пpогpамма, поочеpедно вызывающая pяд функций. (Типичные сценаpии - это .bat файлы). Заме- чу, что в Windows исчез командный язык, поэтому даже такая пpостая задача, как вывод оглавления каталога в файл стала неpазpешимой..3

Одним из главных элементов интеpфейса IDA Pro является «pабочий стол» или в теpминологии IDA Pro «Окно сообщений». Сюда выводится вся инфоpмация, генеpиpуемая IDA Pro или пользовательски- ми скpиптами. Рабочий стол выполнен по типу телетайпа, что вызывает ностальгию по «стаpым боль- шим машинам». Замечу, что оконный интеpфейс все же беpет свое и «телетайп» можно пpокpучивать ввеpх и вниз, что очень удобно и дает возможность пpосматpивать стpоки, скpывшиеся за веpхней гра- ницей экpана. Кpоме этого имеется очень удобная возможность ведения пpотокола. Для этого необхо- димо в окpужение добавить новую пеpеменную IDALOG=logfile Это пpосто незаменимо для тех «кли- нических» случаев, когда Ваш скpипт выводит на Рабочий Стол десятки килобайт инфоpмации,в котоpых pазобpаться скpомными сpедствами навигации окна сообщений становится очень затpуднительно. Са- мая веpхняя стpока - стpока статуса выглядит следующим обpазом:

в AU:-idle- READY 00:30:25

Содеpжимое пунктов меню мы pассмотpим позднее, а пока обpатим внимание на пpавую часть стpоки статуса. Стpелка, напpавленная вниз задает напpавление поиска. Пpямое напpавление «свеpху- вниз» устанавливается по умолчанию, но его можно изменить на обpатное, нажав «Tab», или с помо- щью встpоенной функции Direction(1\0); для этого необходимо нажать Ctrl-F2 и ввести (с соблюдени- ем pегистpа!) Direction(0). Логично, что Direction(1) задет пpямое напpавление. Очень пpиятно, что все «гоpячие» клавиши можно пеpеназначать. Для этого необходимо откpыть в pедактоpе файл ida.cfg и найти секцию «Keyboard hotkey definitions». Ее стpуктуpа очевидна - для каждого Идентификатоpа указывается соответствующая комбинация клавиш. В дальнейшем я буду всегда пpиводить пpототипы всех функций, т.к. каким бы маньяком меня не считали, но я пpивык их набиpать из командной стpоки, что pекомендую и дpугим. В самом деле, набpать команду можно и вслепую, а для выбоpа пункта меню нужно сфокусиpовать на нем внимание. Гоpячие клавиши пpоблемы не pешают, т.к. тpуднее запоминаются и число «эpгономичных» комбинаций весь- ма огpаничено.

Пpавее индикатоpа напpавления находится индикатоp АвтоАнализа. К самому АвтоАнализу мы веpнемся немного позднее, а пока pассмотpим возможные состояния индикатоpа. Что означает буква iзUlч в аббpевиатуpе я так и не смог понять, не написано об этом и в справочной системе програм- мы, функционально это индикатоp, отобpажающий состояние автоанализа. Возможных состояний все- го два:

w iо-idle-lз - АвтоАнализ завеpшен;
w iнdisablelа - АвтоАнализ заблокиpован.

Заблокиpовать автоматический анализ можно как из командной стоки DOS (ключ -a), так и командой встpоенного языка Analysis. Альтеpнативно это можно сделать чеpез Меню Options\Background analysis... Абpевиатуpа iбAClи pасшифpовывается как «Анализ Кода» и спpава указывается текущий ли- нейный адpес. iдPLl. - «PLanned» данный адpес невозможно дизассемблиpовать и он пpопущен. ip@lу - Текущий адpес помечен как iаunexploredlв (неисследованный). Обычно так помечаются данные, тип котоpых IDA Pro pаспознать не в состоянии. Кpоме этого имеется один недокументиpованный индикатоp iоPRlу о назначении котоpого я смутно догадываюсь, но в 3.6 веpсии он видимо недокументиpован. Интеpесно, как обстоят дела с последующими веpсиями? Если индикатоp Вас pаздpажает, то его мож- но выключить чеpез команду AutoShow (long autoshow); гоpячих клавиш для этих действий не пpедусмотpено, но ввиду экзотичности (и бесполезности) самих опеpаций это неудобств, как пpавило не вызывает.

Загрузка

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

В качестве нестандартного примера давайте дизассемблируем главный загрузочный сектор. Запи- шем его в файл mbr.bin. Автоматически IDA Pro загрузит файл с базовым адресом равным нулю, что изменит все смещения и рано или поздно заведет нас в дебри (BIOS грузит MBR в память по адресу.4 0x7C00). Автоматический загрузчик IDA Pro не может знать по какому адресу в памяти должен распо- лагаться данный дамп, поэтому нам придется сделать это самостоятельно. Задать базовое смещение можно из диалога, появляющегося при загрузке, или из командной строки. Но если Вы теперь попыта- етесь это сделать, то IDA Pro сообщит: «Can™t use these switches with the old file» [использование суще- ствующей базы с таким ключом невозможно]. Поэтому прежнюю базу придется удалить. Это нетруд- но сделать вручную, но в пакетном режиме гораздо удобнее использовать специальный ключ -c, кото- рый автоматически удаляет существующие базы без раздражающих запросов и остановок. Обратите внимание, что отсутствие подтверждения может очень дорого стоить, т.к. вся ваша работа будет нео- братимо уничтожена! Но в нашем случае база не содержит никакой полезной информации и, безбо- лезненно расставшись с ней, мы можем внести новые значения в диалог загрузки.

i.Loading segmentlg - это базовый адрес сегмента. Организация памяти в IDA Pro напоминает вирту- альную память 386+ - каждый сегмент (селектор) имеет базовый адрес, который на начальном этапе освоения IDA Pro можно никак не учитывать, но он позднее нам пригодится для работы со скиптами. Кроме того можно в любой момент дозагрузить любой файл по произвольному адресу, что очень удобно, например, при «склеивании» дампов, снятых с разных фрагментов файла. iрLoading offsetln задает начальное смещение для первого элемента загружаемого файла (эквивален- тно директиве ORG в языке макроассемблера). В нашем случае это смещение равно 0x7C00. По умолчанию IDA Pro создает сегменты. Тут необходимо заметить, что ядро IDA Pro устроено так, что все API дизассемблера может работать только с сегментами. Если мы их запретим, то дизассемб- лирование станет невозможным, но это не помешает работе с загруженным образом файла посред- ством командного языка. Обычно этот режим применяется для работы с полностью криптованными файлами или файлами данных. Аналогичную функцию выполняет ключ -x командной строки, но в на- шем примере запрещать создание сегментов мы не будем.

Теперь, пока отрабатывает загрузка и анализ файла, мы вернемся к опциям командной строки. IDA Pro поддерживает множество различных процессорных платформ, но сама, разумеется не может их автоматически определить. Выбираемый по умолчанию процессор можно установить через команду консоли SetPrcsr (char processor) или с помощью кнопи Change processor. В одной и той же линейке процессор может быть перевыбран в любой момент анализа, что само по себе очень приятно, но выб- рать другое семейство процессоров после загрузки уже будет невозможно. Поэтому его необходи- мо задать в командной строке. Для этого существует ключ -p####, где #### символьный код процессора. Поскольку все коды указаны во встроенной помощи, то я здесь их не привожу. Регистр, в котором набираются символы не учитывается, поэтому команды -pz80 и -pZ80 будут эквивалентны. Те же символьные коды используются и в SetPrcst, но напоминаю, что последняя не способна менять се- мейство процессоров во время анализа.

Ключ -b#### позволяет задавать уже упоминавшийся базовый адрес загрузки. По умолчанию он равен 0x1000 и на начальном этапе освоения IDA Pro нет никаких причин для его изменения. Интересно, что в версии 3.6 отсутствует поверка его границ и «увлекшись» можно получить аварийное завершение программы из-за их нарушения. Впрочем, я не интересовался как с этим обстоит в других версиях, поскольку эта ошибка не критична и крайне маловероятна..5 Для изучения заголовка MS DOS PE файлов, можно использовать ключ -n, хотя в нем очень редко бывает что-то достойное внимания, поэтому большей частью эта возможность останется невостребо- ванной. Но всегда приятнее иметь в резерве, чем в критической ситуации лихорадочно искать необхо- димый инструментарий.

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

Для загрузки и автоматического выполнения скипта можно использовать ключ -s filename.idc. Того же эффекта можно добиться, если переименовать файл в ida.idc, который IDA Pro всегда загружает и исполняет (если он существует). Недостаток обоих этих методов в том, что нельзя автоматически ис- полнить несколько файлов. На практике же такая необходимость, к сожалению, встречается достаточ- но часто. Поэтому гораздо удобнее загружать скипты в интерактивном режиме через «IDC file...F2». Небольшие скипы удобнее набирать непосредственно с консоли, вызываемой Shift-F2, но они к сожале- нию не сохраняются при выходе из IDA Pro.

Конфигурация

Кроме командной строки, конфигурацией IDA Pro можно управлять посредством конфигурацион- ных файлов. Это настолько мощный, гибкий и удобный сервис, что его рассмотрим отдельной главой. Все конфигурационные файлы полностью текстовые и представляют собой набор инструкций и оп- ределений для препроцессора в стиле языка Си. Также можно использовать комментарии и включае- мые файлы. Таких файлов два. ida.cfg - управляющий собственно конфигурацией и idc.idc - описыва- ющий прототипы встроенных функций. IDA Pro так же автоматически подключает файл idauser.cfg, но об этом чуть позднее. Все файлы снабжены подробными комментариями, поэтому разобраться с ними будет не трудно.

Конфигурационный файл ida.cfg исполняется в два этапа. Первый проход отрабатывает сразу, как только IDA Pro будет загружена. В этой секции расширения файлов ассоциируются с типом процессо- ра, определяются некоторые рабочие настройки IDA Pro, раскладка «горячих клавиш» и спецификации для конкретных OS.

Первая секция начинается с директивы препроцессора «#ifdef ____» и заканчивается «#else». Воз- можно, по умолчанию, таблица ассоциаций расширенний файлов с типом процессора «DEFAULT_PRO- CESSOR» задана не самым оптимальным образом и может быть легко изменена. В моей версии по умолчанию для .com файлов был задан процессор 8086. На практике же большинство .com файлов используют инструкции более поздних процессоров, поэтому рекомендую установить 80386r. Секция конфигурации памяти позволяет изменить выделяемую для разных нужд память. DATABASE_MEMORY определяет сколько памяти в байтах отводится под имена, строки, перекрестные ссылки и т.д. По умолчанию это значение равно нулю. При этом объем выделяемой IDA Pro памяти равен учетверенной длине загруженного файла, но не менее 128 кб. Для уже дизассемблированного файла выделяемый объем равен размеру базы.

VPAGESIZE (размер виртуальной страницы) по умолчанию равен 4096 байт. С его ростом увеличива- ется скорость работы, но так же все больше и больше теряеться памяти. Особенно актуальным размер используемой памяти будет в том случае, если запрошенный объем превысит ресурсы установленной физической памяти - начнется активная работа с временным файлом Windows на диске. Размер вир- туальной станицы должен представлять собой степень двойки. VPAGES задает размер виртуальной памяти в страницах. По умолчанию он равен нулю, при этом IDA Pro в соответствии с размером страниц выделяет память аналогично DATABASE_MEMORY. Замечу, что эти настойки без достаточной на то нужды лучше не менять, т.к. они выбраны достаточно оптималь- но..6

Секция конфигурации экрана находится в тесной зависимости от используемой операционной систе- мы. Выбором соответствующей ветки конфигурации управляет директива #ifdef _OS_. За MS DOS, например, закреплено определение __MSDOS__. В этом случае IDA Pro запускается в текстовом режиме, который мы можем задать через SCREEN_MODE. По умолчанию он равен нулю, при этом IDA Pro не изменяет текущего видео-режима. Любопытно, что IDA Pro не контролирует, что бы выбранный режим в самом деле был текстовым, поэтому никто нам не помешает запустить ее и в графическом, например, 0x13. Жалко только, что результатов своей работы мы при этом не увидим. Для не-DOS режимов специфицируется не сам видео-режим, а число строк (старший байт) и столб- цов (младший байт).

Выбрать палитру по вкусу нам поможет SCREEN_PALETTE. К сожалению в 3.6 версии выбор все еще небогат. Кроме черно-белого и монохромного (что по сути своей одно и тоже) можно выбрать един- ственный цветной режим, при этом нет никакой возможности управлять цветовой раскладкой. По умолчанию устанавливается режим автодетектирования дисплея и выбор соответствующей кон- фигурации. Секция раскладки горячих клавиш одна из моих самых любимых. Очень положительно ска- зывается на производительности эргономичность работы. Гораздо приятнее установить привычные со- четания, чем использовать в каждом инструменте свои и постоянно в них путаться. По возможности определения назначаемых клавиш эта секция самая гибкая. Большей частью используются строковые ярлыки, такие как «Shift-F2», или отдельные клавиши типа iиClи, но можно задавать и скан-код. Нулевое значение, как не трудно догадаться, не присваивает ни одной горячей клавиши и это действие будет доступно только через систему меню.

На этом первый проход можно считать завершенным. Второй проход начинается с директивы i.#elselр. IDA Pro выполняет второй проход после того, как определен тип процессора, поэтому можно ис- пользовать мульти-конфигурацию с учетом типа. Для платформы Intel это решающего значения не имеет и никаких неудобств от использования одной и той же конфигурации для разных поколений процессо- ров обычно никто не испытывает.

Секция «General parameteres» определяет значения параметров по умолчанию, доступных из меню «опции». Все их можно изменить в любой момент, но все изменения будут запоминаться только в теку- щей базе, а при выборе новой заново считывается из конфигурационного файла. То же самое в полной мере относится и к секциям «Text representation» и «ASCII strings & names». Секция «Translations and allowed character lists» управляет трансляцией символов. Смысл ее ясен с первого взгляда, как и то, что править ее нет необходимости. За исключением тех случаев, когда ис- пользуется несовместимая кодовая таблица. Кроме этого, в конфигурационном файле можно зада- вать клавиатурные макросы.

IDA Pro позволяет записывать их и в интерактивном режиме. Для этого нужно нажать Alt+™-™ и затем сочетание клавиш, с которым данный макрос будет сопоставлен. После этого IDA Pro переходит в ре- жим записи макроса. Мы вводим макро-последовательность, которую завершаем нажатием Alt+™=™. Все, теперь макрос записан и будет исполняться при нажатии на «горячую» клавишу. Я не буду говорить насколько удобно бывает автоматизировать в работе рутинные действия, т.к. это становится ощутимо в первый десяток минут работы с макросами. К сожалению тут нас ждет большой сюрприз. Макросы не запоминаются при выходе из IDA Pro и их ввод приходится повторять сначала. Это искажает саму идею и снижает производительность. Кроме того, я не могу представить себе исследователя, который бы при каждом запуске IDA Pro вводил свои любимые макросы. Использовать пару-тройку макросов по- просту не выгодно, а десяток-другой утомительно (да и бессмысленно) каждый раз вводить вручную. Немного исправить этот недостаток призвана секция описания макросов в файле конфигурации. Тут самое время вспомнить про включаемые файлы. Если в текущей директории существует файл idauser.cfg, то он автоматически подключается. В результате мы можем иметь свои макросы для каж- дого проекта. Разумеется,можно добавить директиву #include user.mac, что бы назначение этого фай- ла стало очевидным. На этом разбор файла ida.cfg можно считать завершенным.




Установка и использование IDA Pro

Дизассемблер позволяет получить ассемблерный текст программы из машинного кода (.exe или .dll модуля). Многие дизассемблеры могут определять имена вызываемых программой API-функций. IDA Pro отличается от других дизассемблеров тем, что он способен опознавать имена не только API-функций, но и функций из MFC (Microsoft Foundation Class - используется программами, написанными на Visual C++) и OWL (Object Windows Library - используется программами, написанными на Borland C++), а также стандартных функций языка Си (таких как fread(), strlen() и т.д.), включенных в код программы.

Установка программы обычно не вызывает никаких проблем. После запуска дизассемблера (файл idaw.exe) появляется окно сессии DOS. Не пугайтесь, IDA Pro - нормальное 32-разрядное приложение, просто оно консольное (работает в окне сессии DOS). Именно поэтому интерфейс IDA Pro напоминает интерфейс обычной DOS-программы.

Отметим несколько моментов, на которые Вам следует обратить внимание перед началом работы с IDA Pro:

  • Практически все настройки (кроме цветовой палитры) осуществляются через файл ida.cfg
  • В первую очередь, давайте поменяем размеры экрана программы. Установленный по умолчанию размер на разрешении 1024*768 не очень удобен, поэтому лучше заменить строку

     SCREEN_MODE = 0 (по умолчанию 32 строки по 80 символов)
     

    на

     SCREEN_MODE = 0x783B (59 строк по 120 символов)- для разрешения 1024х768
     

    это максимальный размер окна, которое умещается на экране. Если у Вас 800х600, можете ничего не менять.
  • При работе с программой я обнаружил одну странную вещь: когда я закрываю IDA Pro, выдается два сообщения о том, что программа выполнила недопустимую операцию и будет закрыта (происходит ошибка при смене видеорежима). Чтобы этого избежать, нужно принудительно установить размер используемого программой шрифта. Для этого:
    • Запомните, как выглядит окно программы при автоматическом выборе шрифта.
    • Из конкретных значений размера шрифта выберите тот, при котором окно примет первоначальный вид. После этого никаких проблем при закрытии программы быть не должно.
  • Для того чтобы не производить подобные изменения при каждом запуске программы, нужно соответствующим образом изменить свойства запускаемого файла. Но установить конкретный размер шрифта при запуске для файла idaw.exe не представляется возможным, т.к. это не DOS-программа, а Windows-приложение и не имеет подобных установок. Лично я для этих целей использую собственный командный файл (файл с расширение .bat). Он содержит только одну строку: idaw.exe В свойствах idaw.bat (так я назвал свой файл) я установил необходимый размер шрифта (для приведенных значений разрешения и размера окна это шрифт 8х12). Теперь, вместо idaw.exe я запускаю idaw.bat - никаких проблем при закрытии больше не возникает.

О приемах работы с IDA Pro Вы познакомитесь в следующих статьях на примере работы с конкретными программами, или можете обратиться к ее полному описанию, которое скоро появится в разделе Описание инструментов. Что ж, со всеми описаниями мы закончили, в следующей статье приступим к исследованию конкретной программы - WinZip 7.0 (beta).




Активизация и использование в IDE окна CPU

CPU not found! Users software emulation!

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

В Delphi 2 эта характеристика встроена, но по умолчанию выключена, называется это окно CPU window, или DisassemblyView. Она легка в использовании, может быть полезной в отладке и сравнении кода при его оптимизации.

Для активизации этой характеристики, запустите REGEDIT и отредактируйте регистры описанным ниже образом. Найдите ключ HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging. Создайте по этому пути строковый ключ с именем "ENABLECPU". Значение нового ключа должно быть строкой "1". Это все. Теперь в Delphi IDE появился новый пункт меню View|CPUWindow. При его активизации выводится новое окно.

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

Создайте 2 одинаковых обработчика события. В каждом обработчике события разместите приведенный ниже код. Установите точку прерывания на первой строчке каждого обработчика. Запустите приложение и активизируйте события. Сравните ассемблерный код обоих методов. Один короче? В этом случае он будет исполняться быстрее.

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

Хорошим примером, где различный код выполняет одну и ту же работу, но делает это с разной скоростью, является использование конструкции "with object do". Исходный код с многократным использованием конструкции "with object do" будет длиннее, но ассемблерный код короче. Вспомните, сколько раз вы устанавливали свойства для динамически создаваемых объектов? Код:


 with TObject.create do
 begin
   property1 := ;
   property2 := ;
   property3 := ;
 end;
 

будет выполняться быстрее, чем


 MyObj := TObject.create;
 MyObj.Property1 := ;
 MyObj.Property2 := ;
 MyObj.Property3 := ;
 




Работа с IDE из программы

Вот подпрограммы, работающие у меня в связке D1 и Win 3.1x:


 function LaunchedFromDelphiIDE: Boolean;
 {----------------------------------------------------------------}
 { Осуществляем проверку запущенности приложения из-под Delphi    }
 { IDE. Идея взята из сообщения в Delphi-Talk от Ed Salgado       }
 { из Eminent Domain Software.                                    }
 {----------------------------------------------------------------}
 
 begin
   LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL} and
   Bool(PWordArray(MemL[DSeg: 36])^[8]);
 end; {LaunchedFromDelphiIDE}
 
 function DelphiLoaded: Boolean;
 {----------------------------------------------------------------}
 { Проверяем, загружена ли Delphi. Дает правильные результаты     }
 {  - если вызывающее приложение запущено отдельно, или из-под IDE}
 {  - если Delphi имеет открытый проект                           }
 {  - если Delphi минимизирована.                                 }
 { Автор идеи Wade Tatman (wtatman@onramp.net).                   }
 {----------------------------------------------------------------}
 
 begin
   DelphiLoaded := false;
   if WindowExists('TPropertyInspector', 'Object Inspector') then
     if WindowExists('TMenuBuilder', 'Menu Designer') then
       if WindowExists('TAppBuilder', '(AnyName)') then
         if WindowExists('TApplication', 'Delphi') then
           if WindowExists('TAlignPalette', 'Align') then
             DelphiLoaded := true;
 end; {DelphiLoaded}
 
 function DelphiInstalled: Boolean;
 {----------------------------------------------------------------}
 { Проверяем наличие Delphi.ini, ищем в нем путь к Библиотеке     }
 { Компонентов, после чего проверяем ее наличие по этому пути.    }
 {----------------------------------------------------------------}
 
 var
   IniFile: string;
 begin
   DelphiInstalled := false;
   IniFile := WindowsDirectory + '\Delphi.ini';
   if FileExists(IniFile) then
     if FileExists(GetIni(IniFile, 'Library', 'ComponentLibrary')) then
       DelphiInstalled := true;
 end; {DelphiInstalled}
 
 Я уверен, что один из приведенных выше методов вам поможет.Последние две
   подпрограммы используют некоторые другие инкапсуляции Windows API и классов
   Delphi, и они определены следующим образом:
 
 function WindowExists(WindowClass, WindowName: string): Boolean;
 {----------------------------------------------------------------}
 { С помощью паскалевских строк проверяем наличие определенного   }
 { окна. Для поиска только имени окна (WindowName), используем    }
 { WindowClass '(AnyClass)'; для поиска только класса окна        }
 { (WindowClass), используем WindowName '(AnyName)'.              }
 {----------------------------------------------------------------}
 
 var
   PWindowClass, PWindowName: PChar;
   AWindowClass, AWindowName: array[0..63] of Char;
 begin
   if WindowClass = '(AnyClass)' then
     PWindowClass := nil
   else
     PWindowClass := StrPCopy(PChar(@AWindowClass), WindowClass);
 
   if WindowName = '(AnyName)' then
     PWindowName := nil
   else
     PWindowName := StrPCopy(PChar(@AWindowName), WindowName);
 
   if FindWindow(PWindowClass, PWindowName) <> 0 then
     WindowExists := true
   else
     WindowExists := false;
 end; {WindowExists}
 
 function WindowsDirectory: string;
 {----------------------------------------------------------------}
 { Возвращаем путь к каталогу Windows (без обратной косой черты)  }
 {----------------------------------------------------------------}
 
 const
   BufferSize = 144;
 var
   ABuffer: array[0..BufferSize] of Char;
 begin
   if GetWindowsDirectory(PChar(@ABuffer), BufferSize) = 0 then
     WindowsDirectory := ''
   else
     WindowsDirectory := StrPas(PChar(@ABuffer));
 end; {WindowsDirectory}
 
 function GetIni(const IniFile, Section, Entry: string): string;
 {----------------------------------------------------------------}
 { Получаем инициализационную 'profile' строку из определенного   }
 { пункта (Entry) определенной секции [Section] определенного     }
 { INI-файла (дополняем '.ini', если отсутствует). Возвращаем     }
 { нулевую строку, если IniFile, Section или Entry не найден.     }
 {----------------------------------------------------------------}
 
 var
   IniFileVar: string;
   IniFileObj: TIniFile;
 begin
   if StrEndsWith(IniFile, '.ini') then
     IniFileVar := IniFile
   else
     IniFileVar := IniFile + '.ini';
   IniFileObj := TIniFile.Create(IniFileVar);
   GetIni := IniFileObj.ReadString(Section, Entry, '');
   IniFileObj.Free;
 end; {GetIni}
 




Как проверить готовность диска А

Автор: Галимарзанов Фанис

Девица не готова - device not ready.


 function DiskInDrive(const Drive: char): Boolean;
 var
   DrvNum: byte;
   EMode: Word;
 begin
   result := false;
   DrvNum := ord(Drive);
   if DrvNum >= ord('a') then
     dec(DrvNum, $20);
   EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
   try
     if DiskSize(DrvNum - $40) <> -1 then
       result := true
     else
       messagebeep(0);
   finally
     SetErrorMode(EMode);
   end;
 end;
 

...можно для пущей функциональности добавить ряд строк:


 function DiskInDrive(const Drive: char): Boolean;
 var
   DrvNum: byte;
   EMode: Word;
 begin
   result := true; // было false
   DrvNum := ord(Drive);
   if DrvNum >= ord('a') then
     dec(DrvNum, $20);
   EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
   try
     while DiskSize(DrvNum - $40) = -1 do
     begin // при неудаче выводим диалог
       if (Application.MessageBox('Диск не готов...' + chr(13) + chr(10) +
         'Повторить?', PChar('Диск ' + UpperCase(Drive)), mb_OKCANCEL +
         mb_iconexclamation {IconQuestion}) = idcancel) then
       begin
         Result := false;
         Break;
       end;
     end;
   finally
     SetErrorMode(EMode);
   end;
 end;
 




Как проверить готовность диска А 2

После игры в покер виндозе выдает сообщение:
- Вы проиграли 273 доллара. Вставьте их, пожалуйста, в дисковод А: и нажмите ANY KEY (если найдете).
Что в этом случае делают...
Ламер: С остервенелым видом начинает засовывать 273 доллара в флоповод А: и искать ANY KEY.
Юзер: С жутко довольным видом давит ресет и бежит рассказывать друзьям о том, как он "взломал" покер.
Хакер: За соседним компутером быстренько пишет прогу, эмулирующую засовывание 273 баксов в дисковод А:. Потом, в течение 3-4 недель пишет фиксы и апдэйты для эмуляции запихивания 274, 293 и 765 баксов в дисководы А:, В.
Новый русский: Со всей дури бьет кулаком по флоповоду А: и начинает усердно искать в флоповоде В: сдачу...


 type
   TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK,
     DS_DISK_WITH_FILES);
 
 function DriveState(driveletter: Char): TDriveState;
 var
   mask: string[6];
   sRec: TSearchRec;
   oldMode: Cardinal;
   retcode: Integer;
 begin
   oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
   mask := '?:\*.*';
   mask[1] := driveletter;
 {$I-} { не возбуждаем исключение при неудаче }
   retcode := FindFirst(mask, faAnyfile, SRec);
   FindClose(SRec);
 {$I+}
   case retcode of
     0: Result := DS_DISK_WITH_FILES; { обнаружен по крайней мере один файл }
     -18: Result := DS_EMPTY_DISK; { никаких файлов не обнаружено, но ok }
     -21: Result := DS_NO_DISK; { DOS ERROR_NOT_READY }
   else
     Result := DS_UNFORMATTED_DISK; { в моей системе значение равно -1785!}
   end;
   SetErrorMode(oldMode);
 end; { DriveState }
 

Я тестировал код под Win NT 3.5, так что проверьте его на ошибки в ситуациях, когда дискета отсутствует или неотформатирована под Win 3.1 и WfW 3.11, если, конечно, это необходимо.

Ревизия для Win95:


 case RetCode of
   0: Result := DS_DISK_WITH_FILES;
   -18: Result := DS_EMPTY_DISK;
   else
     Result := DS_NO_DISK;
 end;
 




Удалить временные файлы IE

На конгрессе программистов зачитывают послание Президента России.... Пожелания удачи, и т.д. А в конце подпись
- "Ваш Президент.Ру"


 uses
   WinInet;
 
 procedure DeleteIECache;
 var
   lpEntryInfo: PInternetCacheEntryInfo;
   hCacheDir: LongWord;
   dwEntrySize: LongWord;
 begin
   dwEntrySize := 0;
   FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
   GetMem(lpEntryInfo, dwEntrySize);
   if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
   hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
   if hCacheDir <> 0 then
   begin
     repeat
       DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
       FreeMem(lpEntryInfo, dwEntrySize);
       dwEntrySize := 0;
       FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
       GetMem(lpEntryInfo, dwEntrySize);
       if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
     until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
   end;
   FreeMem(lpEntryInfo, dwEntrySize);
   FindCloseUrlCache(hCacheDir);
 end;
 
 
 // Beispiel: 
 // Example: 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   DeleteIECache;
 end;
 




Как вызвать команды Find, Options или View Source

Вот пример вызова диалога Find


 const
   HTMLID_FIND       = 1;
   HTMLID_VIEWSOURCE = 2;
   HTMLID_OPTIONS    = 3;
 
 ...
 
 procedure TForm1.FindIE;
 const
   CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
 var
   CmdTarget : IOleCommandTarget;
   vaIn, vaOut: OleVariant;
   PtrGUID: PGUID;
 begin
   New(PtrGUID);
   PtrGUID^ := CGID_WebBrowser;
   if WebBrowser1.Document <> nil then
     try
       WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
       if CmdTarget <> nil then
         try
           CmdTarget.Exec( PtrGUID, HTMLID_FIND, 0, vaIn, vaOut);
         finally
           CmdTarget._Release;
         end;
     except
       // nothing
     end;
   Dispose(PtrGUID);
 end;
 




Получить версию IE

У программиста спросили:
- Почему ваши дети все время ссорятся?
- Конфликт версий.


 uses
   Registry;
 
 function GetIEVersion(Key: string): string;
 var
   Reg: TRegistry;
 begin
   Reg := TRegistry.Create;
   try
     Reg.RootKey := HKEY_LOCAL_MACHINE;
     Reg.OpenKey('Software\Microsoft\Internet Explorer', False);
     try
       Result := Reg.ReadString(Key);
     except
       Result := '';
     end;
     Reg.CloseKey;
   finally
     Reg.Free;
   end;
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.'
     + GetIEVersion('Version')[3]);
   ShowMessage('IE-Version: ' + GetIEVersion('Version'));
   // <major version>.<minor version>.<build number>.<sub-build number> 
 end;
 




Условие создания главной формы

Автор: Neil Rubenking

Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически "другую" форму НЕ нужно будет загружать.

Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения) выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает из друх форм главную:


 begin
   if FALSE then
   begin
     Application.CreateForm(TForm1, Form1);
     Application.CreateForm(TForm2, Form2);
   end;
   Randomize;
   if Random < 0.5 then
     Application.CreateForm(TForm1, Form1)
   else
     Application.CreateForm(TForm2, Form2);
   Application.Run;
 end.
 

Пара "подходящих" для CreateForm форм заключено в никогда не выполнимый блок, тем самым приводя компилятор в состояние свинячего восторга.




Элементы меню на основе изображений

Автор: Neil Rubenking

В своем меню я хочу иметь графику. Но как мне сделать это?

Воспользуйтесь командой ModifyMenu. Тем не менее, Delphi 1.0 имеет привычку СТИРАТЬ изменения в пунктах меню, к примеру, созданных на основе изображения или отрисованных вручную. Если вы пользуетесь этими "фишками", вы НЕ должны осуществлять enable/disable или check/uncheck элементов меню через свойства. Вместо этого вы должны вызывать соответствующие функции Windows API. Вот демонстрационный пример из моей книги Delphi Programming Problem Solver, демонстрирующий элементы меню на основе изображений. Подразумевается, что вы создали форму и главное меню. Меню содержит пустое подменю File (необязательно) и меню верхнего уровня с именем Brush1. Ниже Brush1 вы должны иметь шесть пунктов подменю; их имена могут быть абстрактными, но в приведенном ниже коде они поименованы шестью стилями кисти. Вот сам код:


 unit bitmenuu;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, ExtCtrls, Menus;
 
 type
   TForm1 = class(TForm)
     MainMenu1: TMainMenu;
     File1: TMenuItem;
     Brush1: TMenuItem;
     Horizontal1: TMenuItem;
     Vertical1: TMenuItem;
     FDiagonal1: TMenuItem;
     BDiagonal1: TMenuItem;
     Cross1: TMenuItem;
     DiagCross1: TMenuItem;
     procedure FormCreate(Sender: TObject);
     procedure BrushStyleClick(Sender: TObject);
   private
     { Private declarations }
     Bitmaps: array[0..5] of TBitmap;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   N: Integer;
 begin
   with Brush1 do
     for N := 0 to 5 do
     begin
       Bitmaps[N] := TBitmap.Create;
       with Bitmaps[N], Canvas do
       begin
         Width := 80;
         Height := 16;
         Brush.Color := clMenu;
         Rectangle(0, 0, 80, 16);
         Brush.Color := clMenuText;
         Brush.Style := TBrushStyle(N + 2);
         Rectangle(0, 0, 80, 16);
       end;
       ModifyMenu(Handle, N, MF_BYPOSITION or MF_BITMAP,
         GetMenuItemID(Handle, N), PChar(Bitmaps[N].Handle));
     end;
 end;
 
 procedure TForm1.BrushStyleClick(Sender: TObject);
 var
   N: Integer;
 begin
   with Brush1 do
     for N := 0 to Count - 1 do
 {$IFDEF Win32}
       Items[N].Checked := Items[N] = Sender;
 {$ELSE}
       if Items[N] = Sender then
         CheckMenuItem(Handle, N, MF_BYPOSITION or MF_CHECKED)
       else
         CheckMenuItem(Handle, N, MF_BYPOSITION or MF_UNCHECKED);
 {$ENDIF}
   with Sender as TMenuItem do
     Brush.Style := TBrushStyle(Tag);
   Refresh;
 end;
 
 end.
 

OK, в обработчике события формы OnCreate мы создаем шесть изображений и используем ModifyMenu для их назначения каждому из шести пунктов подменю. В обработчике события OnClick мы, в зависимости от того используется Delphi 2.0 или нет, применяем ту или иную технологию установки атрибутов пункта меню. В Delphi 2.0 мы должны обойти все пункты меню и установить Checked в True только для тех пунктов, на которых щелкали мышью. В Delphi 1.0 мы должны воспользоваться API функцией CheckMenuItem. Попробуйте это!




Плавно превратить один рисунок в другой



 procedure TForm1.Button1Click(Sender: TObject);
 const
   count = 100;
 var
   i: integer;
   x, y: integer;
   bm, bm1, bm2: TBitMap;
   p1, p2, p: PByteArray;
   c: integer;
   k: integer;
 begin
   bm := TBitMap.Create;
   bm1 := TBitMap.Create;
   bm2 := TBitMap.Create;
   bm1.LoadFromFile('Bitmap1.bmp');
   bm2.LoadFromFile('Bitmap2.bmp');
   if bm1.Height < bm2.Height then
   begin
     bm.Height := bm1.Height;
     bm2.Height := bm1.Height;
   end
   else
   begin
     bm.Height := bm2.Height;
     bm1.Height := bm2.Height;
   end;
   if bm1.Width < bm2.Width then
   begin
     bm.Width := bm1.Width;
     bm2.Width := bm1.Width;
   end
   else
   begin
     bm.Width := bm2.Width;
     bm1.Width := bm2.Width;
   end;
   bm.PixelFormat := pf24bit;
   bm1.PixelFormat := pf24bit;
   bm2.PixelFormat := pf24bit;
 
   Form1.Canvas.Draw(0, 0, bm1);
   for i := 1 to count - 1 do
   begin
     for y := 0 to bm.Height - 1 do
     begin
       p := bm.ScanLine[y];
       p1 := bm1.ScanLine[y];
       p2 := bm2.ScanLine[y];
       for x := 0 to bm.Width * 3 - 1 do
         p^[x] := round((p1^[x] * (count - i) + p2^[x] * i) / count);
     end;
     Form1.Canvas.Draw(0, 0, bm);
     Form1.Caption := IntToStr(round(i / count * 100)) + '%';
     Application.ProcessMessages;
     if Application.Terminated then
       break;
   end;
   Form1.Canvas.Draw(0, 0, bm2);
   Form1.Caption := 'done';
   bm1.Destroy; bm2.Destroy; bm.Destroy;
 end;
 




Как поместить картинки в ComboBox

Делается это при помощи стиля ownerdraw, который присутствует в TComboBox. Нас интересуют два свойства этого стиля:

  • csOwnerDrawFixed - используется, если все битмапы имеют одинаковую высоту
  • csOwnerDrawVariable - используется для битмапов с разной высотой

После того как стиль будет установлен на один из вышеперечисленных, то можно воспользоваться событием onDrawItem. Это событие возникает каждый раз, когда приложению необходимо нарисовать пункт в выпадающем списке (combo box). Событие определяется следующим образом:


 procedure TForm1.ComboBox1DrawItem(Control: TWinControl; index: Integer;
 Rect: TRect; State: TOwnerDrawState)
 

Control
Элемент управления, содержащий пункт списка
Index
Номер элемента списка
Rect
прямоугольник, в котором будет отображён элемент списка
State
Состояние элемента: выбран, заблокирован или имеет фокус (odSelected, OdDisabled или OdFocused)

Если выпадающему списку был присвоен стиль csOwnerDrawFixed, то всё, что надо сделать, это написать процедуру, которая будет рисовать битмап и текст в событии onDrawItem.

Для выпадающего списка со стилем csOwnerDrawVariable необходимо пройти ещё одну дополнительную стадию. Заключается эта стадия в создании обработчика для события onMeasureItem. Это событие вызывается перед DrawItem, для того, чтобы Вы могли установить фактическую высоту для каждого элемента списка. Вот его определение:


 procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; index: Integer;
 var Height: Integer);
 

Control
Элемент управления, содержащий пункт списка
Index
Номер элемента списка
Height
Собственно высота элемента списка с номером Index

От теории к практике

Создайте новое приложение. Разместите на форме combobox и imagelist (если Вы используете delphi 1, то Вам прийдётся хранить битмапы каким-то другим способом). В Object Inspector установите следующие свойства:

ComboBox1 -> Style -> csOwnerDrawFixed -> Чтобы мы могли контролировать рисованием элементов.

ComboBox1 -> Items -> Здесь можно добавить любые строки, которые будут отображаться рядом с битмапами. Чтобы каждый элемент имел описание к картинке.

ImageList1 -> Используйте редактор списка картинок (ImageList Editor) Добавьте битмапы в том порядке, в котором они будут отображаться в combobox, а так же проверьте, чтобы они были одного размера. Прозрачный цвет можно установить здесь же. Это картинки, которые появятся в выпадающем списке

В заключение необходимо добавить следующий код для события onDrawItem:


 procedure TForm1.ComboBox1DrawItem(Control: TWinControl; index:Integer;
 Rect: TRect; State: TOwnerDrawState);
 begin
   (* Заполняем прямоугольник *)
   combobox1.canvas.fillrect(rect);
   (* Рисуем сам битмап *)
   imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,index);
   (* Пишем текст после картинки *)
   combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top,
   combobox1.items[index]);
 end;
 




Изменение палитры при выводе изображения

Сообщение MS IE: "Узел найден. Что с ним делать дальше?"

Да, это не тривиальная задача! Палитра дочернего MDI-окна попортила нервов не одному мне.

В обработчике сообщения WM_PaletteChanged вы можете убедиться, что видимая TImage.Picture.Bitmap.Palette всегда "реализована". Так..


 private
 
 procedure WMPaletteChanged(var Msg: TWMPaletteChanged);
   message WM_PaletteChanged;
 
 ...
 
 procedure Form1.WMPaletteChanged(var Msg: TWMPaletteChanged);
 begin
   if Msg.PalChg <> Form1.Handle then
   begin
     PaletteChanged(true);
     Msg.Result := 0;
   end;
 end;
 

Теперь вы можете масштабировать неотображенное изображение как вы хотите и не иметь проблем. Единственное, о чем вам необходимо помнить, если вы хотите вывести неотображенное изображение на видимый TImage, вам необходимо вызвать PaletteChanged снова после того, как изображение выведено. С кодом, который мы использовали...


 Image1.Picture.Bitmap := obitmap;
 PaletteChanged(true);
 

Если вы не делаете этот вызов, изображение отобразится с неправильной палитрой.




За какое время было создано изображение

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

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

При нажатии на Button1 используется свойство Pixels, а при нажатии на Button2 - ScanLine. В заголовок окна выводится время в миллисекундах, за которое было создано изображение.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   t: cardinal;
   x, y: integer;
   bm: TBitmap;
 begin
   bm := TBitmap.Create;
   bm.PixelFormat := pf24bit;
   bm.Width := Form1.ClientWidth;
   bm.Height := Form1.ClientHeight;
   t := GetTickCount;
   for y := 0 to bm.Height - 1 do
     for x := 0 to bm.Width - 1 do
     bm.Canvas.Pixels[x,y] := RGB(x+y, x-y, y-x);
   Form1.Caption := IntToStr(GetTickCount - t);
   Form1.Canvas.Draw(0, 0, bm);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   t: cardinal;
   x, y: integer;
   bm: TBitmap;
   p: PByteArray;
 begin
   bm := TBitmap.Create;
   bm.PixelFormat := pf24bit;
   bm.Width := Form1.ClientWidth;
   bm.Height := Form1.ClientHeight;
   t := GetTickCount;
   for y := 0 to bm.Height - 1 do
   begin
     p := bm.ScanLine[y];
     for x := 0 to bm.Width - 1 do
     begin
       p^[x*3] := x+y;
       p^[x*3+1] := x-y;
       p^[x*3+2] := y-x;
     end;
   end;
   Form1.Caption := IntToStr(GetTickCount - t);
   Form1.Canvas.Draw(0, 0, bm);
 end;
 




Хитрость вывода изображения

Был со мной такой случай. Прихожу я как-то к своим друзьям, а у них Dandy, и они в футбол играют, кнопки жмут. Я взял пульт, стал играть. Через час надоело. Переключаемся на 1-й канал ОРТ, там идёт футбол Спартак с кем-то. Я жму кнопку вправо, а игроки почему-то не бегут, куда я хочу. Жму влево, а они бегут вправо... Только потом дошло, что футбол-то настоящий показывают...

Попробуйте установить:


 Image1.ControlStyle := Image1.ControlStyle + [csOpaque];
 

в обработчике события формы OnCreate (или, по крайней мере прежде, чем вы покажете форму). Компоненты TImage изначально прозрачные (за исключением области, занятой изображением), поэтому сообщая Delphi, что компонент непрозрачен, вы тем самым помешаете что-либо "рисовать" на области, не занятой собственно изображением (типа клиентской области формы).




Заполнение изображением MDI-формы



 procedure TForm.OnPaint(Sender: TObject);
 
   procedure Tile(c: TCanvas; b: TBitMap);
   var
     x, y, h, w, i, j: integer;
   begin
     with b do
     begin
       h := b.height;
       w := b.width;
     end;
     y := 0;
     with c.Cliprect do
     begin
       i := bottom - top - 1; //высота
       j := right - left - 1; //ширина
     end;
     while y < i do
     begin
       x := 0;
       while x < j do
       begin
         c.draw(x, y, b);
         inc(x, w);
       end;
       inc(y, h);
     end;
   end;
 
 begin
   if Sender is TForm then
     Tile(TForm(Sender).Canvas, fTileWith);
 end;
 




Заполнение изображением MDI-формы 2

Автор: Neil Rubenkind

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

Ну наконец-то! Похоже я нашел как решить обе проблемы. Вот код для тех, кому все это интересно. Я начинаю с проблемы дочерних форм, ниже код для решения проблемы с главной формой (модули с именами MDIWAL2U.PAS и MDIWAL1U.PAS). На главной форме расположен компонент TImage с именем Image1, содержащий изображение для заливки фона.


 ...
 private
 { Private declarations }
 
 procedure WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
   message WM_ICONERASEBKGND;
 ...
 
 USES MdiWal1u;
 
 procedure TForm2.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
 begin
   TForm1(Application.Mainform).PaintUnderIcon(Self, Message.DC);
   Message.Result := 0;
 end;
 


 ...
 { Private declarations }
 bmW, bmH: Integer;
 FClientInstance,
 FPrevClientProc: TFarProc;
 
 procedure ClientWndProc(var Message: TMessage);
 public
     procedure PaintUnderIcon(F: TForm; D: hDC);
     ...
       procedure TForm1.PaintUnderIcon(F: TForm; D: hDC);
     var
 
       DestR, WndR: TRect;
       Ro, Co,
         xOfs, yOfs,
         xNum, yNum: Integer;
     begin
 
       {вычисляем необходимое число изображений для заливки D}
       GetClipBox(D, DestR);
       with DestR do
       begin
         xNum := Succ((Right - Left) div bmW);
         yNum := Succ((Bottom - Top) div bmW);
       end;
       {вычисление смещения изображения в D}
       GetWindowRect(F.Handle, WndR);
       with ScreenToClient(WndR.TopLeft) do
       begin
         xOfs := X mod bmW;
         yOfs := Y mod bmH;
       end;
       for Ro := 0 to xNum do
         for Co := 0 to yNum do
           BitBlt(D, Co * bmW - xOfs, Ro * bmH - Yofs, bmW, bmH,
             Image1.Picture.Bitmap.Canvas.Handle,
             0, 0, SRCCOPY);
     end;
 
     procedure TForm1.ClientWndProc(var Message: TMessage);
     var
       Ro, Co: Word;
     begin
 
       with Message do
         case Msg of
           WM_ERASEBKGND:
             begin
               for Ro := 0 to ClientHeight div bmH do
                 for Co := 0 to ClientWIDTH div bmW do
                   BitBlt(TWMEraseBkGnd(Message).DC,
                     Co * bmW, Ro * bmH, bmW, bmH,
                     Image1.Picture.Bitmap.Canvas.Handle,
                     0, 0, SRCCOPY);
               Result := 1;
             end;
           WM_VSCROLL,
             WM_HSCROLL:
             begin
               Result := CallWindowProc(FPrevClientProc,
                 ClientHandle, Msg, wParam, lParam);
               InvalidateRect(ClientHandle, nil, True);
             end;
         else
           Result := CallWindowProc(FPrevClientProc,
             ClientHandle, Msg, wParam, lParam);
         end;
     end;
 
     procedure TForm1.FormCreate(Sender: TObject);
     begin
 
       bmW := Image1.Picture.Width;
       bmH := Image1.Picture.Height;
       FClientInstance := MakeObjectInstance(ClientWndProc);
       FPrevClientProc := Pointer(
         GetWindowLong(ClientHandle, GWL_WNDPROC));
       SetWindowLong(ClientHandle, GWL_WNDPROC,
         LongInt(FClientInstance));
     end;
 




Заполнение изображением MDI-формы 3

Автор: Alexander N.Voronin

В разделе Заполнение изображением MDI-формы повторяющимся изображением. Я нашел (Copyright не мой а из книжки) более простой способ.


 ...
 private
   OutCanvas: TCanvas;
   OldWinProc, NewWinProc: Pointer;
 
 procedure NewWinProcedure(var Msg: TMessage);
 ...
 
 procedure TMainForm.FormCreate(Sender: TObject);
 begin
   NewWinProc := MakeObjectInstance(NewWinProcedure);
   OldWinProc := Pointer(SetWindowLong(ClientHandle,
     gwl_WndProc, Cardinal(NewWinProc)));
   OutCanvas := TCanvas.Create;
 end;
 
 procedure TMainForm.NewWinProcedure(var Msg: TMessage);
 var
   BmpWidth, BmpHeight: Integer;
   I, J: Integer;
 begin
   // default processing first
   Msg.Result := CallWindowProc(OldWinProc,
     ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);
 
   // handle background repaint
   if Msg.Msg = wm_EraseBkgnd then
   begin
     BmpWidth := MainForm.Image1.Width;
     BmpHeight := MainForm.Image1.Height;
     if (BmpWidth <> 0) and (BmpHeight <> 0) then
     begin
       OutCanvas.Handle := Msg.wParam;
       for I := 0 to MainForm.ClientWidth div BmpWidth do
         for J := 0 to MainForm.ClientHeight div BmpHeight do
           OutCanvas.Draw(I * BmpWidth, J * BmpHeight,
             MainForm.Image1.Picture.Graphic);
     end;
   end;
 end;
 
 procedure TMainForm.FormDestroy(Sender: TObject);
 begin
   OutCanvas.Free;
 end;
 




Заполнение изображением MDI-формы 4

Автор: Nomadic


 type
   .... = class(TForm)
     ....
       procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     ....
     private
     FHBrush: HBRUSH;
     FCover: TBitmap;
     FNewClientInstance: TFarProc;
     FOldClientInstance: TFarProc;
     procedure NewClientWndProc(var Message: TMessage);
     ....
     protected
     ....
       procedure CreateWnd; override;
     ....
   end;
 
   .....
 
 implementation
 
 {$R myRes.res} //pесуpс с битмапом фона
 
 procedure.FormCreate(...);
   var
   LogBrush: TLogbrush;
 begin
   FCover := TBitmap.Create;
   FCover.LoadFromResourceName(hinstance, 'BMPCOVER');
   with LogBrush do
   begin
     lbStyle := BS_PATTERN;
     lbHatch := FCover.Handle;
   end;
   FHBrush := CreateBrushIndirect(Logbrush);
 end;
 
   procedure.FormDestroy(...);
     begin
       DeleteObject(FHBrush);
       FCover.Free;
     end;
 
     procedure.CreateWnd;
     begin
       inherited CreateWnd;
       if (ClientHandle <> 0) then
       begin
         if NewStyleControls then
           SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or
             GetWindowLong(ClientHandle, GWL_EXSTYLE));
 
         FNewClientInstance := MakeObjectInstance(NewClientWndProc);
         FOldClientInstance := pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
         SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FNewClientInstance));
       end;
     end;
 
     procedure.NewClientWndProc(var Message: TMessage);
 
       procedure Default;
       begin
         with Message do
           Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg,
             wParam,
             lParam);
       end;
 
     begin
       with Message do
       begin
         case Msg of
           WM_ERASEBKGND:
             begin
               FillRect(TWMEraseBkGnd(Message).DC, ClientRect, FHBrush);
               Result := 1;
             end;
         else
           Default;
         end;
       end;
     end;
 




Карта высот картинки


 {
  вы знаете что такое карта высот?
  можно создать супер эффект  на простом Canvas
  к сожалению мой код моргает при перерисовке,
  но вы уж поковыряйтесь.... :)
 }
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ExtCtrls, StdCtrls, ExtDlgs, math, ComCtrls, ShellApi;
 
 type
   TForm1 = class(TForm)
     Image1: TImage;
     OpenDialog1: TOpenDialog;
     Timer1: TTimer;
     PageControl1: TPageControl;
     Specular: TTabSheet;
     sRed: TEdit;
     Label1: TLabel;
     ScrollBar1: TScrollBar;
     Label2: TLabel;
     sGreen: TEdit;
     ScrollBar2: TScrollBar;
     ScrollBar3: TScrollBar;
     sBlue: TEdit;
     Label3: TLabel;
     Label4: TLabel;
     Edit1: TEdit;
     ScrollBar4: TScrollBar;
     Diffuse: TTabSheet;
     Ambient: TTabSheet;
     Label5: TLabel;
     Label6: TLabel;
     Label7: TLabel;
     dGreen: TEdit;
     dBlue: TEdit;
     dRed: TEdit;
     ScrollBar5: TScrollBar;
     ScrollBar6: TScrollBar;
     ScrollBar7: TScrollBar;
     Label8: TLabel;
     Label9: TLabel;
     Label10: TLabel;
     aBlue: TEdit;
     aGreen: TEdit;
     aRed: TEdit;
     ScrollBar8: TScrollBar;
     ScrollBar9: TScrollBar;
     ScrollBar10: TScrollBar;
     Label11: TLabel;
     Label12: TLabel;
     Edit2: TEdit;
     Label13: TLabel;
     procedure FormCreate(Sender: TObject);
     procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
     procedure ScrollBarChange(Sender: TObject);
     procedure Label11Click(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 type
   normal = record
     x: integer;
     y: integer;
   end;
 
 type
   rgb32 = record
     b: byte;
     g: byte;
     r: byte;
     t: byte;
   end;
 type
   rgb24 = record
     r: integer;
     g: integer;
     b: integer;
   end;
 
 var
   Form1: TForm1;
   bumpimage: tbitmap;
   current_X, Current_Y: integer;
 var
   Bump_Map: array[0..255, 0..255] of normal;
   Environment_map: array[0..255, 0..255] of integer;
   Palette: array[0..256] of rgb24;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 type
   image_array = array[0..255, 0..255] of byte;
 var
   x, y: integer;
   Buffer: image_array;
   bump_file: file of image_array;
   ny2, nx, nz: double;
   c: integer;
   ca, cap: double;
 begin
   assignfile(bump_File, 'bump.raw');
   reset(Bump_File);
   Read(Bump_File, buffer);
   for y := 1 to 254 do
   begin
     for x := 1 to 254 do
     begin
       Bump_Map[x, y].x := buffer[y + 1, x] - buffer[y + 1, x + 2];
       bump_map[x, y].y := buffer[y, x + 1] - buffer[y + 2, x + 1];
     end;
   end;
   closefile(bump_File);
 
   for y := -128 to 127 do
   begin
     nY2 := y / 128;
     nY2 := nY2 * nY2;
     for X := -128 to 127 do
     begin
       nX := X / 128;
       nz := 1 - SQRT(nX * nX + nY2);
       c := trunc(nz * 255);
       if c < = 0 then
         c := 0;
       Environment_Map[x + 128, y + 128] := c;
     end;
   end;
 
   nx := pi / 2;
   ny2 := nx / 256;
   for y := 0 to 255 do
   begin
     ca := cos(nx);
     cap := power(ca, 35);
     nx := nx - ny2;
     palette[y].r := trunc((128 * ca) + (235 * cap));
     if palette[y].r > 255 then
       palette[y].r := 255;
     palette[y].G := trunc((128 * ca) + (245 * cap));
     if palette[y].g > 255 then
       palette[y].g := 255;
     palette[y].B := trunc(5 + (170 * ca) + (255 * cap));
     ;
     if palette[y].b > 255 then
       palette[y].b := 255;
   end;
   bumpimage := TBitmap.create;
   bumpimage.width := 255;
   bumpimage.height := 255;
   bumpimage.PixelFormat := pf32bit;
   Image1.Picture.Bitmap := bumpimage;
   image1mousemove(self, [], 128, 128);
   application.ProcessMessages;
 
 end;
 
 procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 begin
   Current_X := x;
   Current_Y := y;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   x, y, x2, y2, y3: integer;
   Scan: ^Scanline;
   bx, by: longint;
   c: byte;
 begin
   x := Current_X;
   y := Current_Y;
   for y2 := 0 to 253 do
   begin
     scan := image1.Picture.Bitmap.ScanLine[y2];
     y3 := 128 + y2 - y;
     for x2 := 0 to 253 do
     begin
       bx := bump_Map[x2, y2].x + 128 + x2 - x;
       by := bump_Map[x2, y2].y + y3;
       if (bx < 255) and (bx > 0) and (by < 255) and (by > 0) then
       begin
         c := Environment_Map[bx, by];
         scan^[x2].r := palette[c].r;
         scan^[x2].g := palette[c].g;
         scan^[x2].b := palette[c].b;
       end
       else
       begin
         scan^[x2].r := palette[0].r;
         scan^[x2].g := palette[0].g;
         scan^[x2].b := palette[0].b;
       end;
       {image1.Canvas.Pixels[x,y] := rgb(r,g,b);}
     end;
   end;
   image1.Refresh;
 
 end;
 
 procedure TForm1.ScrollBarChange(Sender: TObject);
 var
   ny2, nx: double;
   c: integer;
   ca, cap: double;
 begin
   sRed.Text := inttostr(scrollbar1.position);
   sGreen.Text := inttostr(scrollbar2.position);
   sBlue.Text := inttostr(scrollbar3.position);
   edit1.Text := inttostr(scrollbar4.position);
 
   dRed.Text := inttostr(scrollbar5.position);
   dGreen.Text := inttostr(scrollbar6.position);
   dBlue.Text := inttostr(scrollbar7.position);
 
   aRed.Text := inttostr(scrollbar8.position);
   aGreen.Text := inttostr(scrollbar9.position);
   aBlue.Text := inttostr(scrollbar10.position);
 
   nx := pi / 2;
   ny2 := nx / 256;
   for C := 0 to 255 do
   begin
     ca := cos(nx);
     cap := power(ca, scrollbar4.position);
     nx := nx - ny2;
     palette[c].r := trunc(scrollbar8.position + (scrollbar5.position * ca) +
       (scrollbar1.position * cap));
     if palette[c].r > 255 then
       palette[c].r := 255;
     palette[c].G := trunc(scrollbar9.position + (scrollbar6.position * ca) +
       (scrollbar2.position * cap));
     if palette[c].g > 255 then
       palette[c].g := 255;
     palette[c].B := trunc(scrollbar10.position + (scrollbar7.position * ca) +
       (scrollbar3.position * cap));
     ;
     if palette[c].b > 255 then
       palette[c].b := 255;
   end;
   image1mousemove(self, [], Current_X, Current_Y);
   application.ProcessMessages;
 
 end;
 
 procedure TForm1.Label11Click(Sender: TObject);
 begin
   ShellExecute(handle, 'open', 'http://wkweb5.cableinet.co.uk/daniel.davies/',
     nil, nil, SW_SHOWNORMAL);
 end;
 
 end.
 




Перемещение Image

Однажды врач, инженер-строитель и программист поспорили о том, чья профессия древнее. Врач заметил:
- В Библии сказано, что Бог сотворил Еву из ребра Адама. Такая операция может быть проведена только хирургом, поэтому я по праву могу утверждать, что моя профессия самая древняя в мире.
Тут вмешался инженер-строитель и сказал:
- Но еще раньше Бог сотворил небо и землю из хаоса. Это первое, и, несомненно, наиболее выдающееся применение строительной инженерии. Поэтому, дорогой доктор, вы не правы. Моя профессия самая древняя в мире.
Программист при этих словах откинулся в кресле, загадочно улыбнулся и веско произнес:
- Да, но кто, как вы думаете, сотворил хаос?

Многие, наверно, сталкивались с проблемой перемещения Image'a по форме. Решить ее можно тремя способами (может есть и больше, но я знаю только три). Способ первый. Его суть заключается в том, что свойства Left и Top картинки изменяются на разницу между начальными и конечными координатами (нажатия и отпускания мыши соответственно). Этот способ самый простой и надежный, но у него есть один недостаток: left и top изменяются по очереди, что приводит к заметному мерцанию картинки. Тем не менее мы этот способ рассмотрим. Не забудьте положить на форму Image и вставить в нее какую-нибудь картинку. Для начала необходимо объявить глобальные переменные (они объявляются в разделе Implementation) x0, y0:integer - они будут запоминать начальные координаты. И еще нам понадобится переменная move типа boolean, чтобы нам отличать перемещение мыши над картинкой, от попытки ее сдвинуть. Эти объявления делаются примерно так:


 implementation
 {$R *.DFM}
 
 var
   x0, y0: integer;
   move: boolean;
 

Теперь напишем обработчик OnMouseDown для нашей картинки:


 procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   if button <> mbLeft then
     move:=false //если нажали не левой кнопкой, то перемещать не будем!
   else
   begin
     move:=true;
     x0:=x; //запоминаем начальные координаты
     y0:=y; //запоминаем начальные координаты
   end;
 end;
 

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


 procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 begin
   if move then
   begin
     image1.Left:=image1.Left+x-x0; // Изменяем позицию левого края
     image1.Top:=image1.Top+y-y0; // Изменяем позицию верхнего края
   end;
 end;
 

Ну и наконец обработчик OnMouseUp для нашей картинки будет таким:


 procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   move := false;
 end;
 

Здесь все очень просто. Когда кнопка отпускается, то переменной move присваивается значение false, чтобы до следующего клика по картинке ее нельзя было сдвинуть. Этот способ довольно прост, как для понимания, так и для реализации. Но такой же алгоритм перемещения можно реализовать немного красивее. У некоторых компонентов, в том числе и Image, есть такая классная процедура SetBounds(Left,Top,Width,Height), которая может изменять сразу все четыре параметра. Таким образом событие OnMouseMove можно изменить так:


 procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 begin
   if move then
     image1.SetBounds(image1.Left+x-x0, image1.Top+y-y0,
     image1.width, image1.height);
 end;
 

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


 procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   if button<>mbLeft then
     move:=false
   else
   begin
     move:=true;
     x0:=x;
     y0:=y;
     rec:=image1.BoundsRect; //запоминаем контур картинки
   end;
 end;
 
 procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 begin
   if move then
   begin
     Form1.Canvas.DrawFocusRect(rec); //рисуем рамку
     with rec do
     begin
       left:=Left+x-x0;
       top:=Top+y-y0;
       right:=right+x-x0;
       bottom:=bottom+y-y0;
       x0:=x;
       y0:=y; // изменяем координаты
     end;
     Form1.Canvas.DrawFocusRect(rec); // рисуем рамку на новом месте
   end;
 end;
 
 procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   Form1.Canvas.DrawFocusRect(rec);
   with image1 do begin
     setbounds(rec.left+x-x0,rec.top+y-y0,width,height); //перемещаем картинку
     move:=false;
   end;
 end;
 

Поскольку DrawFocusRect рисует рамку методом Xor, то при повторном вызове этой функции с теми же параметрами, рамка стирается. Этот очень красивый метод добавит в ваши программы много интересного.




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

Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.


 type
   TForm1 = class(TForm)
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
     procedure FormMouseMove(Sender: TObject;
     Shift: TShiftState; X, Y: Integer);
     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
   private
     {Private declarations}
     Capturing : bool;
     Captured : bool;
     StartPlace : TPoint;
     EndPlace : TPoint;
   public
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 function MakeRect(Pt1: TPoint; Pt2: TPoint): TRect;
 begin
   if pt1.x < pt2.x then
   begin
     Result.Left := pt1.x;
     Result.Right := pt2.x;
   end
   else
   begin
     Result.Left := pt2.x;
     Result.Right := pt1.x;
   end;
   if pt1.y < pt2.y then
   begin
     Result.Top := pt1.y;
     Result.Bottom := pt2.y;
   end
   else
   begin
     Result.Top := pt2.y;
     Result.Bottom := pt1.y;
   end;
 end;
 
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   if Captured then
     DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace, EndPlace));
   StartPlace.x := X;
   StartPlace.y := Y;
   EndPlace.x := X;
   EndPlace.y := Y;
   DrawFocusRect(Form1.Canvas.Handle, MakeRect(StartPlace, EndPlace));
   Capturing := true;
   Captured := true;
 end;
 
 procedure TForm1.FormMouseMove(Sender: TObject;
 Shift: TShiftState; X, Y: Integer);
 begin
   if Capturing then
   begin
     DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
     EndPlace.x := X;
     EndPlace.y := Y;
     DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
   end;
 end;
 
 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 begin
   Capturing := false;
 end;
 




Вращение изображения

Автор: Mike Williams

- Каково состояние Билла Гейтса?
- Каждому китайцу по 40 баксов...

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


 procedure RotateRight(BitMap: tImage);
 var
   FirstC, LastC, c, r: integer;
 
   procedure FixPixels(c, r: integer);
   var
     SavePix, SavePix2: tColor;
     i, NewC, NewR: integer;
   begin
     SavePix := Bitmap.Canvas.Pixels[c, r];
     for i := 1 to 4 do
     begin
       newc := BitMap.Height - r + 1;
       newr := c;
       SavePix2 := BitMap.Canvas.Pixels[newc, newr];
       Bitmap.Canvas.Pixels[newc, newr] := SavePix;
       SavePix := SavePix2;
       c := Newc;
       r := NewR;
     end;
   end;
 
 begin
   if BitMap.Width <> BitMap.Height then
     exit;
   BitMap.Visible := false;
   with Bitmap.Canvas do
   begin
     firstc := 0;
     lastc := BitMap.Width;
     for r := 0 to BitMap.Height div 2 do
     begin
       for c := firstc to lastc do
       begin
         FixPixels(c, r);
       end;
       inc(FirstC);
       Dec(LastC);
     end;
   end;
   BitMap.Visible := true;
 end;
 




Вращение изображения 2

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

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

Для преобразования X- и Y-координат объявлены следующие переменные:

X,Y    = старые координаты пикселя
 X1,Y1  = новые координаты пикселя
 T      = угол вращения (в радианах)
 
 R, A   - промежуточные величины, представляющие собой полярные координаты
 
 R = Sqrt(Sqr(X) + Sqr(Y));
 
 A = Arctan(Y/X);
 
 X1 = R * Cos(A+T);
 
 Y1 = R * Sin(A+T);
Я отдаю себе отчет, что это не оптимальное решение, поэтому, если вы найдете еще какое-либо решение, дайте мне знать. В действительности мой метод работает, но делает это очень медленно.

Создайте наложение пиксель-на-пиксель исходного изображение на целевое (используя свойство Canvas.Pixels).

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

Для начала вот мой вариант формулы вращения:

x, y = координаты в целевом изображении
 t = угол
 u, v = координаты в исходном изображении
 
 x = u * cos(t) - v * sin(t)
 y = v * cos(t) + u * sin(t)
Теперь, если я захочу решить эти уравнения и вычислить u и v (привести их к правой части уравнения), то формулы будут выглядеть следующим образом (без гарантии, по этой причине я и включил исходные уравнения!):
      x * cos(t) + y
 u = --------------------
     sqr(cos(t)) + sin(t)
 
 v =   y * cos(t) - x
     --------------------
     sqr(cos(t)) + sin(t)

Так, подразумевая, что вы уже знаете угол вращения, можно вычислить константы cos(t) и 1/sqr(cos(t))+sin(t) непосредственно перед самим циклом; это может выглядеть примерно так (приблизительный код):


 ct := cos(t);
 ccst := 1/sqr(cos(t))+sin(t);
 for x := 0 to width do
 
 for y := 0 to height do
 dest.pixels[x,y] := source.pixels[Round((x * ct + y) * ccst),
 Round((y * ct - x) * ccst)];
 

Если вы хотите ускорить этот процесс, и при этом волнуетесь за накопление ошибки округления, то вам следует обратить внимание на используемую нами технологию: мы перемещаем за один раз один пиксель, дистанция между пикселями равна u, v содержит константу, определяющую колонку с перемещаемым пикселем. Я использую расчитанные выше переменные как рычаг с коротким плечом (с вычисленной длиной и точкой приложения). Просто поместите в (x,y) = (1,0) и (x,y) = (0,1) и уравнение, приведенное выше:


 duCol := ct * ccst;
 dvCol := -ccst;
 
 duRow := ccst;
 dvRow := ct * ccst;
 
 uStart := 0;
 vStart := 0;
 
 for x := 0 to width do
 begin
   u := uStart;
   v := vStart;
   for y := 0 to height do
   begin
     dest.pixels[x, y] := source.pixels[Round(u), Round(v)];
     u := u + rowdu;
     v := v + rowdv;
   end;
   uStart := uStart + duCol;
   vStart := vStart + dvCol;
 end;
 

Приведенный выше код можно использовать "как есть", и я не даю никаких гарантий отностительно его использования!

Если вы в душе испытатель, и хотите попробовать вращение вокруг произвольной точки, попробуйте поиграться со значенияим u и v:

Xp, Yp (X-sub-p, Y-sub-p) точка оси вращения, другие константы определены выше
 x = Xp + (u - Xp) * cos(t) - (y - Yp) * sin(t)
 y = Yp + (y - Yp) * cos(t) - (x - Xp) * sin(t)
Оригинальные уравнения:
  x = u * cos(t) - v * sin(t)
   y = v * cos(t) + u * sin(t)
верны, но когда я решаю их для u и v, я получаю это:
      x * cos(t) + y * sin(t)
   u = -----------------------
      sqr(cos(t)) + sqr(sin(t))
 
 
       y * cos(t) - x * sin(t)
   v = ------------------------
       sqr(cos(t)) + sqr(sin(t))



Запись картинки в ADO таблицу


 ADOQuery1.Edit;
 TBLOBField(ADOQuery1.FieldByName('myField')).LoadFromFile('c:\my.bmp');
 ADOQuery1.Post;
 




Загрузка изображений в Blob-поля

Имеется несколько способов загрузки изображения в BLOB-поле таблицы dBASE или Paradox. Три самых простых метода включают в себя:

  1. копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем
  2. использование метода LoadFromFile компонента TBLOBField
  3. использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.
Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.

Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

Вот исходный код примера, копирующий содержание буфера обмена в компонент TDBImage, если содержащиеся в буфере данные имеют формат изображения:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   C: TClipboard;
 begin
   C := TClipboard.Create;
   try
     if Clipboard.HasFormat(CF_BITMAP) then
       DBImage1.PasteFromClipboard
     else
       ShowMessage('Буфер обмена не содержит изображения!');
   finally
     C.Free;
   end;
 end;
 

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

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):


 procedure TForm1.Button2Clicck(Sender: TObject);
 begin
   Table1Bitmap.LoadFromFile(
     'c:\delphi\images\splash\16color\construc.bmp');
 end;
 

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

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


 procedure TForm1.Button3Click(Sender: TObject);
 var
   B: TBitmap;
 begin
   B := TBitmap.Create;
   try
     B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
     DBImage1.Picture.Assign(B);
   finally
     B.Free;
   end;
 end;
 




Помещение изображения в буфер обмена

Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения width, height, left и top, приведенные в коде, на реальные. Если вы действительно хотите вырезать, а не копировать область, то вам понадобиться ее залить с помощью вызова функции fillrect.


 Var
   BitMap: TBitmap;
 begin
   BitMap:=TBitMap.Create;
   BitMap.Height:=BaseKeyPanel.Height;
   BitMap.Width:=BaseKeyPanel.Width;
   BitBlt(BitMap.Canvas.Handle, 0 {Лево}, 0{Top},
   BaseKeyPanel.Width, BaseKeyPanel.Height,
   GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
   Clipboard.Assign(BitMap);
   BitMap.Free;
 End;
 




Как поместить графический элемент в TListBox

Сначала создайте bmp-файл, который вы будете помещать около каждого элемента списка, в примере это 'c:\file.bmp'. Для создания файла можете воспользоваться специальной графической утилитой ImageEditor, которая входит в пакет Delphi. Желательно, чтобы размер файлы был 16х16. После этого вынесите на форму компонент TListBox. Его свойство Style установите в lbOwnerDrawVariable - это позволит нам прорисовывать каждый элемент списка самостоятельно.

Далее объявляем переменную:


 var
   Bit: TBitmap;
 

После этого задаём обработчику события OnDrawItem следующий вид:


 procedure TForm1.ListBox1DrawItem(Control: TWinControl; index: Integer;
 Rect: TRect; State: TOwnerDrawState);
 var
   cc: TCanvas;
 begin
   cc:=(Control as TListBox).Canvas;
   cc.FillRect(rect);
   cc.Draw(Rect.Left+Rect.Right-16,Rect.Top,Bit);
   cc.TextOut(Rect.Left,Rect.Top,ListBox1.Items[index]);
 end;
 

а обработчику события OnMeasureItem такой:


 procedure TForm1.ListBox1MeasureItem(Control: TWinControl;
 index: Integer; var Height: Integer);
 begin
   Height := 16;
 end;
 

По созданию окна создаёт Bitmap и загружаем в него данные из файла:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Bit := TBitmap.Create;
   Bit.LoadFromFile('c:\file.bmp');
 end;
 

По уничтожению окна - уничтожаем Bitmap


 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   Bit.Destroy;
 end;
 




Помещение изображения в ячейку StringGrid

Возможно ли поместить изображение в одну из ячеек компонента StringGrid?

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


 with StringGrid1.Canvas do
 begin
   {...}
   Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);
   {...}
 end;
 

Достичь цели позволяют методы Draw() и StretchDraw() объекта TCanvas. В приведенном примере переменная Image1 класса TImage содержит заранее загруженное изображение.




Протокол IMAP4

В интернете появился сайт психиатрической больницы. Адрес: www, бе-бе-бе, ме-ме-ме, фр-фр-фр!

Протокол IMAP4 (Internet Message Access Protocol) позволяет клиентам получать доступ и манипулировать сообщениями электронной почты на сервере. Существенным отличием протокола IMAP4 от протокола РОРЗ является то, что IMAP4 поддерживает работу с системой каталогов (или папок) удаленных сообщений так же, как если бы они располагались на локальном компьютере. IMAP4 позволяет клиенту создавать, удалять и переименовывать почтовые ящики, проверять наличие новых сообщений и удалять старые. Благодаря тому что IMAP4 поддерживает механизм уникальной идентификации каждого сообщения в почтовой папке клиента, он позволяет читать из почтового ящика только сообщения, удовлетворяющие определенным условиям или их части, менять атрибуты сообщений и перемещать отдельные сообщения. Структура папок в значительной степени зависит от типа почтовой системы, но в любой системе у клиента есть специальный каталог INBOX, куда попадают поступающие клиенту сообщения.

Принципы работы

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

Принцип передачи данных IMAP4 такой же как и у других подобных протоколов. Сначала клиент и сервер обмениваются приветствиями. Затем клиент отправляет на сервер команды и данные. Сервер, соответственно, передает клиенту ответы на обработку команд и данных. После завершения обмена канал закрывается.

             +-------------------------------------------------+
 
             | установление соединения и приветствие  сервера  |
 
             +-------------------------------------------------+
 
                       || (1)       || (2)        || (3)
 
                       VV           ||            ||
 
             +-----------------+    ||            ||
 
             |не установленное |    ||            ||
 
             +-----------------+    ||            ||
 
              || (7)   || (4)       ||            ||
 
              ||       VV           VV            ||
 
              ||     +----------------+           ||
 
              ||     | установленное  |<=++       ||
 
              ||     +----------------+  ||       ||
 
              ||       || (7)   || (5)   || (6)   ||
 
              ||       ||       VV       ||       ||
 
              ||       ||    +--------+  ||       ||
 
              ||       ||    |выбора  |==++       ||
 
              ||       ||    +--------+           ||
 
              ||       ||       || (7)            ||
 
              VV       VV       VV                VV
 
             +--------------------------------------+
 
             | завершение сеанса и закрытие связи   |
 
             +--------------------------------------+
 
         
  1. связь без установления подлинности (приветствие ОК)
  2. связь перед регистрацией (приветствие PREAUTH)
  3. отклоненная связь (приветствие BYE)
  4. успешное выполнение команды LOGIN или AUTHENTICATE
  5. успешное выполнение команды SELECT или EXAMINE
  6. команда CLOSE, или не успешное выполнение команды SELECT или EXAMINE
  7. команда LOGOUT, отключение сервера или прерывание связи

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

Весь обмен данными между клиентом и сервером организован в виде строк, завершающихся символами , либо в виде последовательности байт заданной длины. Каждая команда клиента начинается с идентификатора или тега команды. Тег, как правило, представляет собой короткую строку, состоящую из букв и цифр, (например, А0001,А0002 и т. д.). Тег является уникальным идентификатором данной команды клиента. Ответы сервера или следующие команды клиента могут ссылаться на данную команду по ее тегу.

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

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

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

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

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

Каждое общение в почтовой системе для работы с IMAP имеет уникальный идетификатор, по которому можно получить доступ к этому сообщению. УНИКАЛЬНЫЙ идентификатор UID представляет собой 32-битное число, которое идентифицирует сообщение в данной папке. Каждому сообщению, попавшему папку, присваивается максимальное число из UID-сообщении попавших данную папку ранее. Уникальные идентификаторы сообщении сохраняются от сессии к сессии и могут использоваться, например, для синхронизации каталогов мобильных пользователей.

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

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

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

  • "\Seen" - обозначает, что данное сообщение было прочитано
  • "\Answered" - на сообщение был дан ответ
  • "\Deleted" - сообщение помечено на удаление
  • "\Draft" - формирование данного сообщения еще не завершено
  • "\Recent" - сообщение "только что" поступило в почтовый ящик, т. е. данная сессия - первая, которая может прочитать это сообщение.
  • "\Recent" - пример флага, который не сохранится в следующей сессии.

Кроме того, на сервере IMAP хранятся дата и время получения сообщения сервером. Например, если сообщение получено по SMTP, то фиксируется дата и время доставки по адресу назначения, общий размер сообщения, структура сообщения (MIМЕ-структура).

Основные команды

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

  • Команда LOGIN. После того как по транспортному протоколу (например, TCP), было установлено соединение, и от сервера пришла строка приветствия, клиент должен зарегистрироваться в системе. Для этого чаще всего используется команда LOGIN. Аргументом команды является строка с идентификатором и паролем клиента:

 S: * OK IMAP4 revl Service Ready
 С: aOOl login ali sesam
 S; aOOl OK LOGIN completed
 

Команда LOGIN передает пароль и идентификатор пользователя по сети в открытом виде. Если пользователю необходима защита информации своей почты, он может пользоваться командой AUTHENTICATE. Аргументом команды является строка, указывающая механизм аутентификации, которым желает воспользоваться данный пользователь. В зависимости от выбранного типа аутентификации строится дальнейший обмен между сервером и клиентом. Например, при использовании механизма шифрования KERBEROS, аутентификация выглядит следующим образом:


 S: * OK KerberosV4 IMAP4revl Server
 С: АО 01 AUTHENTICATE KERBEROS_V4
 S: + AmFYig==
 C: BAcAQrJ5EUkVXLkNNVS5FRFUAOCAsho84kLN3/IJmrMG+25a4DT
 +nZIiriJjnTNHJUtxAA+oOKPKfHEcAFs9a3CL50ebe/ydHJUwYFd
 WwuQlMWiy6IesKvjL5rL9WjXUb9MwT9bpObYLGOKilQh
 S: + or//EoAADZI=
 C: DiAF5MgA+oOIALuBkAAmw==
 S: A001 OK Kerberos V4 authentication successful
 

  • После регистрации в системе клиент должен выбрать каталог (папку) сообщений, с которым он будет работать. Выбор каталога осуществляется командой SELECT. Аргументом команды является имя почтового каталога:

 С А142 SELECT INBOX
 S * 172 EXISTS
 S * 1 RECENT
 S * OK [UNSEEN 12) Message 12 is first unseen
 S * OK [UIDVALIDITY 3857529045] UIDs valid
 S * FLAGS (\Answered \Flagged \Deleted \Seen \Draft)
 S * OK [PERMANENTFLAGS (\Deleted \Seen \*)] Limited
 S A142 OK [READ-WRITE] SELECT completed
 

Сервер 1МАР4, прежде чем подтвердить завершение обработки команды, передает клиенту атрибуты данного каталога. В показанном выше примере:

  • В папке "INBOX" - 172 сообщения (строка "* 172 EXISTS")
  • Из них одно только что поступившее (строка "* 1 RECENT").
  • В папке есть непрочитанные сообщения, минимальный порядковый номер непрочитанного сообщения - 12 (строка "* OK [UNSEEN 12] Message 12 is first unseen"),
  • Уникальный временный идентификатор папки INBOX в данной сессии - 3857529045 (строка "* OK [UIDVAL1DITY 3857529045] UIDs valid").
  • Сообщения в данной папке могут иметь флаги, указанные в строке FLAGS (строка "* FLAGS (\Answered \Flageed VDeleted N^" \Draft)").
  • Клиент может менять у сообщений флаги "\Deleted" и "\Seen" (строка "* OK [PERMANENTFLAGS (\Deleted \Seen \*)] Limited ").
  • Клиент имеет права на запись и чтение сообщений из INBOX (строка "А142 OK [READ-WRITE] SELECT completed").

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


 С: А932 EXAMINE bloop
 S: * 17 EXISTS
 ...
 

  • Команда EXAMINE возвращает те же параметры, что и команда SELECT, а отличается от команды SELECT только тем, что открывает заданный почтовый ящик исключительно на чтение.

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


 <>ttС: Д042 STATUS blob (MESSAGES UNSEEN)
 S: * STATUS blob (MESSAGES 231 UNSEEN 12)
 S: A042 OK STATUS completed
 

  • Чтобы получить список папок (подкаталогов), находящихся в определенной папке и доступных клиенту, можно воспользоваться командой LIST. Аргументами команды являются: имя каталога, список подкаталогов который хотим получить (пустая строка - "" означает текущий каталог) и маска имен подкаталогов. Имена каталогов и маски имен подкаталогов могут интерпритироваться по-разному, в зависимости от реализации почтовой системы и структуры описания иерархии папок. Например, список папок, находящихся в корне, можно получить так:

 С: А004 LIST "/" *
 S: * LIST (\Noinferiors ) "/" INBOX
 S: * LIST (\Noinferiors ) "/"•• OUTBOX
 S: * LIST (\Noinferiors ) "/".. WasteBox
 S: A004 OK LIST completed
 

Ответ сервера содержит список папок в соответствии с их положением в иерархии и флаги данных папок (флаг "\Noinferiors" означает, что внутри данной папки нет и не может быть построена иерархия).

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

 С: А654 FETCH 10:12 BODY [HEADER]
 S: * 10 FETCH (BODY [HEADER] {350}
 S: Date: Wed, 17 Jul 1996 02:23:25 -0700 (PDTl
 S: From: raan@globe.com
 S: Subject: Hi
 S: To: imap@world.edu
 S: Message-Id:
 S^ mime-Vresion: 1.0
 S: Content-Type: TEXT/PLAIN; CHARSET=US-ASCII
 S:
 S: )
 S: *11 FETCH ....
 S: *12 FETCH ....
 S: A654 OK FETCH completed
 

  • После просмотра сообщения, пользователь может сохранить его с другими флагами, добавить или удалить флаги сообщения ( пометить данное сообщение на удаление). Для этого используется команда STORE. Аргументами команды являются: номера сообщений, идентификатор операции и перечень флагов. Например, операция добавления флага удаления ("\Dеleted") трем сообщениям выглядит следующим образом:

 С: АОО3 SТОRЕ 2:4 +FLAGS (\DELETED)
 S: *2 FETCH FLAGS (\Deleted \ Seen)
 S: *3 FETCH FLAGS (\Deleted )
 S: *4 FETCH FLAGS (\Deleted \Flagged \Seen)
 S: A003 OK STORE completed
 

Ответом на выполнение команды будут переданы строки новых флагов указанных сообщений.

  • Пользователь также может организовать поиск сообщений по определенным критериям. Для этого используется команда SEARCH. Критерий поиска состоит из комбинации нескольких условий поиска, а результатом поиска будет множество сообщений, находящихся в пересеченных условий. Условия могут налагаться на состав, структуру тела или заголовка сообщений, а также на флаги, размер, идентификатор периоды дат сообщений. Результатом работы команды является строка, состоящая из последовательных номеров сообщений, удовлетворяющих критерию поиска. Например, поиск всех непрочитанных сообщений, поступивших от "smith" с 1-03-96 будет выглядеть так:

 C: A282 SEARCH UNSEEN FROM 'Smith" SINCE 1-Mar-1996
 S: * SEARCH 2 84 882
 S: A282 OK SEARCH completed
 

Результатом поиска будут сообщения с последовательными номерами 2, 84 и 882. * IMAP4 позволяет не только искать и читать сообщения в каталогах, этот протокол позволяет добавлять, копировать и перемещать сообщения в каталоги. Добавление сообщения в папку можно осуществить командой APPEND:


 C: A003 APPENDSAVED-MESSAGES (\Seen) {310}
 C: Date: Mon, 7 Feb 1997 21:52:25 - 0800 {PST}
 C: From: Fred Foobar
 C: Subject: aftenoon meeteng
 C: TO: mooch@owatagu.siam.edu
 C: Message-Id:
 C: Mime-Version: 1.0
 C: Content-Type: Text/PLAIN; CHARSET=US-ASCII
 C:
 C: Hello Joe, do you think we can meet at 3:30 tomorrow?
 C:
 S: A003 OK APPEND completed
 

  • Команда COPY копирует сообщения с заданными порядковыми номерами в указанный каталог, например:

 C: A003 COPY 2:4 MEETENG
 S: A003 OK COPY completed
 




Симуляция нажатия кнопки при наличии DBGrid

Автор: OAmiry (Borland)

Сын спрашивает у отца:
- Папа, а что такое Windows-98?
- Это сынок как обрезание - во-первых, это красиво...
- А во-вторых?
- Когда пытаешься его лечить, может стать еще хуже!

В случае нажатия клавиши Enter, клавиша по умолчанию не срабатывает, если у вас на форме расположен компонент DBGrid, но вы можете создать обработчик события DBGrid OnKeypUp, уведомляющий кнопку по умолчанию о ее "нажатии" при реальном нажатии клавиши Enter. Пример:


 {Код DBGrid OnKeyUp. Default-кнопка - BitBtn1.}
 if Key = VK_RETURN then
 begin
   PostMessage(BitBtn1.Handle, WM_LBUTTONDOWN, Word(0), LongInt(0)) ;
   PostMessage(BitBtn1.Handle, WM_LBUTTONUP, Word(0), LongInt(0)) ;
 end ;
 




Импорт большого CSV файла

Скачивание файла.
Размер: неизвестно (скачено 45%).


 var s: String; f: TextFile;
 AssignFile(f, 'D:\\INPUT.TXT);
 Reset(f);
 while not EOF(f) do
   begin
    ReadLn(s, f);
    ShowMessage(GetField(s, 1));  {The first field\}
    ShowMessage(GetField(s, 6));  {The sixth field\}
    ShowMessage(GetField(s, 25)); {will return '' if no 25 column...\}
   end;
 CloseFile(f);
 
 { ==== This function will return a field from a delimited string. ==== \}
 function GetField(InpString: String; fieldpos: Integer): String;
 var
   c: Char;
   curpos, i: Integer;
 begin
   curpos := 1;
   for i := 1 to fieldpos do
     begin
      result := ''; if curpos > Length(InpString) then Break;
      repeat
        c := InpString[curpos]; Inc(curpos, 1);
        if (c = '"') or (c = #13) or (c = #10) then c := ' ';
        if c <> ',' then result := result + c;
        until (c = ',') or (curpos > Length(InpString))
     end;
   if (curpos > Length(InpString)) and (i < fieldpos) then result := '';
   result := Trim(result);
 end;
 
 { ==== This function will trim a string removing spaces etc. ==== \}
 function Trim(inp_str: String): String;
 var
   i: Integer;
 begin
   for i := 1 to Length(inp_str) do if inp_str[i] <> ' ' then Break;
   if i > 1 then Delete(inp_str, 1, i - 1);
   for i := Length(inp_str) downto 1 do if inp_str[i] <> ' ' then Break;
   if i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str));
   result := inp_str;
   if result = ' ' then result := '';
 end;
 




Импорт больших файлов с разделителями

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


 var
   s: string;
   f: TextFile;
   AssignFile(f, 'D:\INPUT.TXT');
   Reset(f);
   while not EOF(f) do
 
   begin
     ReadLn(s, f);
     ShowMessage(GetField(s, 1)); {Первое поле}
     ShowMessage(GetField(s, 6)); {Шестое поле}
     ShowMessage(GetField(s, 25)); {возвратит '', если нет 25 колонки...}
   end;
   CloseFile(f);
 
   { ==== Данная функция возвращает поле из строки с разделителем. ==== }
 
 function GetField(InpString: string; fieldpos: Integer): string;
 var
 
   c: Char;
   curpos, i: Integer;
 begin
 
   curpos := 1;
   for i := 1 to fieldpos do
   begin
     result := '';
     if curpos > Length(InpString) then
       Break;
     repeat
       c := InpString[curpos];
       Inc(curpos, 1);
       if (c = '"') or (c = #13) or (c = #10) then
         c := ' ';
       if c <> ',' then
         result := result + c;
     until (c = ',') or (curpos > Length(InpString))
   end;
   if (curpos > Length(InpString)) and (i < fieldpos) then
     result := '';
   result := Trim(result);
 end;
 
 { ==== Данная функция удаляет у строки левые и правые пробелы. ==== }
 
 function Trim(inp_str: string): string;
 var
 
   i: Integer;
 begin
 
   for i := 1 to Length(inp_str) do
     if inp_str[i] <> ' ' then
       Break;
   if i > 1 then
     Delete(inp_str, 1, i - 1);
   for i := Length(inp_str) downto 1 do
     if inp_str[i] <> ' ' then
       Break;
   if i < Length(inp_str) then
     Delete(inp_str, i + 1, Length(inp_str));
   result := inp_str;
   if result = ' ' then
     result := '';
 end;
 




Импортирование, или обертка вызовов функций DLL

Импортирование, или 'обертка' вызовов функций DLL

Существует два метода для импорта и загрузки функций из Dynamic Link Library (DLL). Первый метод (который широко обсуждается в данном документе), называется "неявной" (Implicit) загрузкой. Неявная загрузка включает в себя статическую загрузку DLL при запуске программы, и получение доступа к функциям через интерфейс объектного Паскаля. Данный метод должен использоваться в случае, если приложение полностью зависит от загрузки DLL для соответствующего функционирования. Другой метод доступа называется "явной" загрузкой, поскольку DLL загружается динамически по требованию. Этот метод требует дополнительного кодирования и должен использоваться, если приложению нужно работать в случае, даже если DLL не смогла правильно загрузиться.

Что такое "обертка" функциональных вызовов?

Обертка функции, или набора функций, состоит из объявлений в секции interface и кода в секции implementation (вместе со связанными константами или типами), которые соответствуют функции, или набору функций, импортируемых из DLL. Обертка является простой декларацией в паскалевском модуле, которая обеспечивает точку входа в DLL. В Delphi обертка представляет собой файл модуля, содержащий код объектного паскаля. Группа разработчиков Delphi уже создала для вас обертку функций и стандартных элементов управления Windows. Но иногда возникает необходимость создания обертки для вызовов функций dll, но это в Delphi не обернуто по случаю сугубой индивидуальности каждой DLL и входящих в нее функций.

Первым, и самым сложным шагом в данном процессе является получение информации о функциях. Один из лучших источников для получения документации об имеющихся (доступных) в DLL функций является World Wide Web. Начать поиск можно с MSDN, а если и там нет информации, то можно обратиться к многочисленным поисковым серверам, которые частенько находят нужную вам информацию. Для получения структуры вызовов функций ищите залоговочные файлы C++ в продуктах типа Borland C++ или MS Visual C++. Соглашения об вызовах и преобразованиях типов обычно способны разрешить конфликты и несовместимость вызовов между C++ и PASCAL. Хороший ресурс по вопросам совместимости между Delphi и C++ расположен на сайте Borland по адресу: http://www.borland.com/delphi/papers/brick.html.

После того, как вы нашли необходимый пример, или документацию об экспортируемых DLL функциях, то следующим шагом будет создание нового модуля. Интерфейс модуля будет содержать константы и типы, необходимые для вызова отдельных функций DLL, и заголовки самих функций. Данные заголовки функций являются объектно-паскалевским интерфейсом, позволяющим другим приложениям Delphi вызывать функции рассматриваемой DLL. Как только секция модуля interface будет завершена, следующей секцией будет implementation. Секция модуля implementation содержит объявления импортируемых внешних функций. Эти заголовки не идентичны тем, которые расположены в секции модуля interface (которые содержат реальные идентификаторы функций плюс другую важную информацию для реализации). Для получения дополнительной информации по этой теме обратитесь к топику "DLLs:accessing procedures and functions" справки помощи по Delphi 3.

Представим себе, что у нас есть функция с именем BOB в DLL с именем 'BLODGE.DLL'. (ниже приведены подробные и необходимые шаги, где подразумевается, что мы будем использовать неявную загрузку DLL):

  1. Поиск информации по Интернету показал, что функция BOB должна возвращать логическое значение и требует в качестве аргументов значения типа word и boolean.
  2. Создайте в Delphi новый файл модуля с именем 'UseBob.pas' (File|New и выберите unit)
  3. Следующая строка кода должна располагаться в секции interface нового модуля:

  4.  function BOB(Fire: Word; Dances: Boolean): Boolean; stdcall;
     

  5. Следующая строка кода должна располагаться в секции implementation нового модуля:

  6.  function BOB; external 'BLODGE';
     

  7. Сохраните модуль с именем 'UseBob.pas'.
  8. Необходимо убедиться в том, что UseBob.pas расположен в каталоге текущего проекта, или находится в каталоге, прописанном в путях поиска Delphi.
  9. Добавьте к списку uses модуля нового проекта модуль 'UseBob'. Теперь функция BOB может быть вызвана из нового проекта подобно любой другой стандартной функции.
  10. Во время выполнения приложения BLODGE.DLL должен находится в пути текущих переменных окружения процесса.
Для способа, при котором 'BLODGE.DLL' должна быть загружена явно, требуется дополнительное кодирование. Как было подчеркнуто выше, необходимо знание аргументов функций/процедур (и тип результата в случае функции).

Ниже приведен модуль с реализацией вызова функции BOB, инициализируемый при нажатии на кнопку:


 unit UDLLTest;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
   { Вот типы, которые требуются для работы нашей функции bob }
 
   TBOB = function(Fire: Word; Dances: Boolean): Boolean; stdcall;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   BOB: TBOB;
   hDLLInst: THandle;
   IsAlive, IsDancing: Boolean;
   Years: Word;
 
 begin
 
   { Загружаем и получаем дескриптор нашего BLODGE.DLL }
   hDLLInst := LoadLibrary('BLODGE.DLL');
   { Если загрузка не была успешной, генерируем свое исключение }
   if (hDLLInst <= 0) then
     raise exception.create('[Неудачный вызов LoadLibrary]');
   { Попытаемся получить адрес функции BOB }
   try
     @BOB := GetProcAddress(hDLLInst, 'BOB');
     if not assigned(BOB) then
       raise exception.Create('[Неудачный вызов GetProcAddress]');
     Years := 25;
     IsDancing := True;
     { Теперь мы можем выполнить функцию BOB }
     IsAlive := BOB(Years, IsDancing);
   finally
     { Освобождаем дескриптор DLL }
     FreeLibrary(hDLLInst);
   end;
 end;
 
 end.
 




Расширяем возможности кнопок в Delphi

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

Пример тестировался под WinNT, SP5 и WIN95, SP1.

Также можно создать до 4-х изображений для индикации состояния кнопки

Вы так же можете присвоить кнопке текстовый заголовок. Можно расположить текст и изображение в любом месте кнопки. Для этого в пример добавлены четыре свойства:

TextTop и TextLeft
Для расположения текста заголовка на кнопке,
GlyphTop и GlyphLeft
Для расположения Glyph на кнопке.

Текст заголовка прорисовывается после изображения, потому что они используют одно пространство кнопки, и соответственно заголовок прорисуется поверх изображения. Бэкграунд текста сделан прозрачным. Соответственно мы увидим только текстовые символы поверх изображения.

Найденные баги

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

 unit NewButton;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 const
   fShift = 2; // Изменяем изображение и заголовок , когда кнопка нажата.
   fHiColor = $DDDDDD; // Цвет нажатой кнопки (светло серый)
   // Windows создаёт этот цвет путём смешивания пикселей clSilver и clWhite (50%).
   // такой цвет хорошо выделяет нажатую и отпущенную кнопки.
 
 type
   TNewButton = class(TCustomControl)
   private
     { Private declarations }
     fMouseOver,fMouseDown : Boolean;
     fEnabled : Boolean;
     // То же, что и всех компонент
     fGlyph : TPicture;
     // То же, что и в SpeedButton
     fGlyphTop,fGlyphLeft : Integer;
     // Верх и лево Glyph на изображении кнопки
     fTextTop,fTextLeft : Integer;
     // Верх и лево текста на изображении кнопки
     fNumGlyphs : Integer;
     // То же, что и в SpeedButton
     fCaption : string;
     // Текст на кнопке
     fFaceColor : TColor;
     // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки
 
     procedure fLoadGlyph(G : TPicture);
     procedure fSetGlyphLeft(I : Integer);
     procedure fSetGlyphTop(I : Integer);
     procedure fSetCaption(S : string);
     procedure fSetTextTop(I : Integer);
     procedure fSetTextLeft(I : Integer);
     procedure fSetFaceColor(C : TColor);
     procedure fSetNumGlyphs(I : Integer);
     procedure fSetEnabled(B : Boolean);
 
   protected
     { Protected declarations }
     procedure Paint; override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
     procedure WndProc(var message : TMessage); override;
     // Таким способом компонент определяет - находится ли курсор мышки на нём или нет
     // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки.
     // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса.
 
   public
     { Public declarations }
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
 
   published
     { Published declarations }
     {----- Properties -----}
     property Action;
     // Property AllowUp не поддерживается
     property Anchors;
     property BiDiMode;
     property Caption : string
     read fCaption write fSetCaption;
     property Constraints;
     property Cursor;
     // Property Down не поддерживается
     property Enabled : Boolean
     read fEnabled write fSetEnabled;
     // Property Flat не поддерживается
     property FaceColor : TColor
     read fFaceColor write fSetFaceColor;
     property Font;
     property Glyph : TPicture // Такой способ позволяет получить серую кнопку, которая сможет
     // находиться в трёх положениях.
     // После нажатия на кнопку, с помощью редактора картинок Delphi
     // можно будет создать картинки для всех положений кнопки..
     read fGlyph write fLoadGlyph;
     // Property GroupIndex не поддерживается
     property GlyphLeft : Integer
     read fGlyphLeft write fSetGlyphLeft;
     property GlyphTop : Integer
     read fGlyphTop write fSetGlyphTop;
     property Height;
     property Hint;
     // Property Layout не поддерживается
     property Left;
     // Property Margin не поддерживается
     property name;
     property NumGlyphs : Integer
     read fNumGlyphs write fSetNumGlyphs;
     property ParentBiDiMode;
     property ParentFont;
     property ParentShowHint;
     // Property PopMenu не поддерживается
     property ShowHint;
     // Property Spacing не поддерживается
     property Tag;
     property Textleft : Integer
     read fTextLeft write fSetTextLeft;
     property TextTop : Integer
     read fTextTop write fSetTextTop;
 
     property Top;
     // Property Transparent не поддерживается
     property Visible;
     property Width;
     {--- События ---}
     property OnClick;
     property OnDblClick;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
 end;
 
 procedure register; // Hello
 
 implementation
 
 
 procedure TNewButton.fSetEnabled(B : Boolean);
 begin
   if B <> fEnabled then
   begin
     fEnabled := B;
     Invalidate;
   end;
 end;
 
 procedure TNewButton.fSetNumGlyphs(I : Integer);
 begin
   if I > 0 then
     if I <> fNumGlyphs then
     begin
       fNumGlyphs := I;
       Invalidate;
     end;
 end;
 
 procedure TNewButton.fSetFaceColor(C : TColor);
 begin
   if C <> fFaceColor then
   begin
     fFaceColor := C;
     Invalidate;
   end;
 end;
 
 procedure TNewButton.fSetTextTop(I : Integer);
 begin
   if I >= 0 then
     if I <> fTextTop then
     begin
       fTextTop := I;
       Invalidate;
     end;
 end;
 
 procedure TNewButton.fSetTextLeft(I : Integer);
 begin
   if I >= 0 then
     if I <> fTextLeft then
     begin
       fTextLeft := I;
       Invalidate;
     end;
 end;
 
 procedure TNewButton.fSetCaption(S : string);
 begin
   if fCaption <> S then
   begin
     fCaption := S;
     SetTextBuf(PChar(S));
     Invalidate;
   end;
 end;
 
 procedure TNewButton.fSetGlyphLeft(I : Integer);
 begin
   if I <> fGlyphLeft then
     if I >= 0 then
     begin
       fGlyphLeft := I;
       Invalidate;
     end;
 end;
 
 procedure TNewButton.fSetGlyphTop(I : Integer);
 begin
   if I <> fGlyphTop then
     if I >= 0 then
     begin
       fGlyphTop := I;
       Invalidate;
     end;
 end;
 
 procedure tNewButton.fLoadGlyph(G : TPicture);
 var
   I : Integer;
 begin
   fGlyph.Assign(G);
   if fGlyph.Height > 0 then
   begin
     I := fGlyph.Width div fGlyph.Height;
     if I <> fNumGlyphs then
       fNumGlyphs := I;
   end;
   Invalidate;
 end;
 
 procedure register; // Hello
 begin
   RegisterComponents('Samples', [TNewButton]);
 end;
 
 constructor TNewButton.Create(AOwner : TComponent);
 begin
   inherited Create(AOwner);
   { Инициализируем переменные }
   Height := 37;
   Width := 37;
   fMouseOver := False;
   fGlyph := TPicture.Create;
   fMouseDown := False;
   fGlyphLeft := 2;
   fGlyphTop := 2;
   fTextLeft := 2;
   fTextTop := 2;
   fFaceColor := clBtnFace;
   fNumGlyphs := 1;
   fEnabled := True;
 end;
 
 destructor TNewButton.Destroy;
 begin
   if Assigned(fGlyph) then
     fGlyph.Free; // Освобождаем glyph
   inherited Destroy;
 end;
 
 procedure TNewButton.Paint;
 var
   fBtnColor,fColor1,fColor2,
   fTransParentColor : TColor;
   Buffer : array[0..127] of Char;
   I,J : Integer;
   X0,X1,X2,X3,X4,Y0 : Integer;
   DestRect : TRect;
   TempGlyph : TPicture;
 begin
   X0 := 0;
   X1 := fGlyph.Width div fNumGlyphs;
   X2 := X1 + X1;
   X3 := X2 + X1;
   X4 := X3 + X1;
   Y0 := fGlyph.Height;
   TempGlyph := TPicture.Create;
   TempGlyph.Bitmap.Width := X1;
   TempGlyph.Bitmap.Height := Y0;
   DestRect := Rect(0,0,X1,Y0);
 
   GetTextBuf(Buffer,SizeOf(Buffer)); // получаем caption
   if Buffer <> '' then
     fCaption := Buffer;
 
   if fEnabled = False then
     fMouseDown := False; // если недоступна, значит и не нажата
 
   if fMouseDown then
   begin
     fBtnColor := fHiColor; // Цвет нажатой кнопки
     fColor1 := clWhite; // Правая и нижняя окантовка кнопки, когда на неё нажали мышкой.
     fColor2 := clBlack; // Верхняя и левая окантовка кнопки, когда на неё нажали мышкой.
   end
   else
   begin
     fBtnColor := fFaceColor; // fFaceColor мы сами определяем
     fColor2 := clWhite; // Цвет левого и верхнего края кнопки, когда на неё находится курсор мышки
     fColor1 := clGray; // Цвет правого и нижнего края кнопки, когда на неё находится курсор мышки
   end;
 
   // Рисуем лицо кнопки :)
   Canvas.Brush.Color := fBtnColor;
   Canvas.FillRect(Rect(1,1,Width - 2,Height - 2));
 
   if fMouseOver then
   begin
     Canvas.MoveTo(Width,0);
     Canvas.Pen.Color := fColor2;
     Canvas.LineTo(0,0);
     Canvas.LineTo(0,Height - 1);
     Canvas.Pen.Color := fColor1;
     Canvas.LineTo(Width - 1,Height - 1);
     Canvas.LineTo(Width - 1, - 1);
   end;
 
   if Assigned(fGlyph) then // Bitmap загружен?
   begin
     if fEnabled then // Кнопка разрешена?
     begin
       if fMouseDown then // Мышка нажата?
       begin
         // Mouse down on the button so show Glyph 3 on the face
         if (fNumGlyphs >= 3) then
           TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
         fGlyph.Bitmap.Canvas,Rect(X2,0,X3,Y0));
 
         if (fNumGlyphs < 3) and (fNumGlyphs > 1)then
           TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
         fGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0));
 
         if (fNumGlyphs = 1) then
           TempGlyph.Assign(fGlyph);
 
         // Извините, лучшего способа не придумал...
         // Glyph.Bitmap.Прозрачность цвета не работает, если Вы выберете в качестве
         // прозрачного цвета clWhite...
         fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
         for I := 0 to X1 - 1 do
           for J := 0 to Y0 - 1 do
             if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
               TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
         //Рисуем саму кнопку
         Canvas.Draw(fGlyphLeft + 2,fGlyphTop + 2,TempGlyph.Graphic);
       end
       else
       begin
         if fMouseOver then
         begin
           // Курсор на кнопке, но не нажат, показываем Glyph 1 на морде кнопки
           // (если существует)
           if (fNumGlyphs > 1) then
             TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
           fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
           if (fNumGlyphs = 1) then
             TempGlyph.Assign(fGlyph);
         end
         else
         begin
           // Курсор за пределами кнопки, показываем Glyph 2 на морде кнопки (если есть)
           if (fNumGlyphs > 1) then
             TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
           fGlyph.Bitmap.Canvas,Rect(X1,0,X2,Y0));
           if (fNumGlyphs = 1) then
             TempGlyph.Assign(fGlyph);
         end;
         // Извиняюсь, лучшего способа не нашёл...
         fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
         for I := 0 to X1 - 1 do
           for J := 0 to Y0 - 1 do
             if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
               TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
         //Рисуем bitmap на морде кнопки
         Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
       end;
     end
     else
     begin
       // Кнопка не доступна (disabled), показываем Glyph 4 на морде кнопки (если существует)
       if (fNumGlyphs = 4) then
         TempGlyph.Bitmap.Canvas.CopyRect(DestRect, fGlyph.Bitmap.Canvas,Rect(X3,0,X4,Y0))
       else
         TempGlyph.Bitmap.Canvas.CopyRect(DestRect, fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
       if (fNumGlyphs = 1) then
         TempGlyph.Assign(fGlyph.Graphic);
 
       // Извините, лучшего способа не нашлось...
       fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
       for I := 0 to X1 - 1 do
         for J := 0 to Y0 - 1 do
           if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
             TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
       //Рисуем изображение кнопки
       Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
     end;
   end;
 
   // Рисуем caption
   if fCaption <> '' then
   begin
     Canvas.Pen.Color := Font.Color;
     Canvas.Font.name := Font.name;
     Canvas.Brush.Style := bsClear;
     //Canvas.Brush.Color := fBtnColor;
     Canvas.Font.Color := Font.Color;
     Canvas.Font.Size := Font.Size;
     Canvas.Font.Style := Font.Style;
 
     if fMouseDown then
       Canvas.TextOut(fShift + fTextLeft,fShift + fTextTop,fCaption)
     else
       Canvas.TextOut(fTextLeft,fTextTop,fCaption);
   end;
 
   TempGlyph.Free; // Освобождаем временный glyph
 end;
 
 
 // Нажата клавиша мышки на кнопке ?
 procedure TNewButton.MouseDown(Button: TMouseButton;
   Shift: TShiftState;X, Y: Integer);
 var
   ffMouseDown, ffMouseOver: Boolean;
 begin
   ffMouseDown := True;
   ffMouseOver := True;
   if (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
   begin
     fMouseDown := ffMouseDown;
     fMouseOver := ffMouseOver;
     Invalidate; // не перерисовываем кнопку без необходимости.
   end;
   inherited MouseDown(Button,Shift,X,Y);;
 end;
 
 // Отпущена клавиша мышки на кнопке ?
 procedure TNewButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
   X, Y: Integer);
 var
   ffMouseDown, ffMouseOver : Boolean;
 begin
   ffMouseDown := False;
   ffMouseOver := True;
   if (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
   begin
     fMouseDown := ffMouseDown;
     fMouseOver := ffMouseOver;
     Invalidate; // не перерисовываем кнопку без необходимости.
   end;
   inherited MouseUp(Button,Shift,X,Y);
 end;
 
 // Эта процедура перехватывает события мышки, если она даже за пределами кнопки
 // Перехватываем оконные сообщения
 procedure TNewButton.WndProc(var message : TMessage);
 var
   P1,P2 : TPoint;
   Bo : Boolean;
 begin
   if Parent <> nil then
   begin
     GetCursorPos(P1); // Получаем координаты курсона на экране
     P2 := Self.ScreenToClient(P1); // Преобразуем их в координаты относительно кнопки
     if (P2.X > 0) and (P2.X < Width) and (P2.Y > 0) and (P2.Y < Height) then
       Bo := True // Курсор мышки в области кнопки
     else
       Bo := False; // Курсор мышки за пределами кнопки
 
     if Bo <> fMouseOver then // не перерисовываем кнопку без необходимости.
     begin
       fMouseOver := Bo;
       Invalidate;
     end;
   end;
   inherited WndProc(message); // отправляем сообщение остальным получателям
 end;
 
 end.
 




Инкрементальный поиск в ListBox

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


 procedure TForm1.Edit1Change(Sender: TObject);
 var
   Ndx: Word;
 begin
   with Sender as TEdit do
   begin
     Ndx := ListBox1.Items.Add(Text);
     ListBox1.Items.Delete(Ndx);
     if CompareText(Text, Copy(ListBox1.Items[Ndx], 1, Length(Text))) = 0 then
       ListBox1.ItemIndex := Ndx
     else
       ListBox1.ItemIndex := -1;
   end;
 end;
 

Пытаясь вставить часть текста, вы просто просматриваете список на предмет его наличия. Если актуальный элемент в этой позиции содержит "частичный" текст, мы выводим его, в противном случае делаем так, чтобы ListBox не имел выделенного (ItemIndex) элемента.




Инкрементальный поиск в ListBox 2

Автор: Ralph Friedman

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

Как это осуществить на Delphi?

Здесь придется немного воспользоваться Win API. Установите свойство формы KeyPreview в True и сделайте примерно следующее:


 unit LbxSrch;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;
 
 type
   TFrmLbxSrch = class(TForm)
     Edit1: TEdit;
     Edit2: TEdit;
     ListBox1: TListBox;
     Label1: TLabel;
     procedure FormKeyPress(Sender: TObject; var Key: Char);
     procedure ListBox1Enter(Sender: TObject);
   private { Private declarations }
     FPrefix: array[0..255] of char;
   public
     { Public declarations }
   end;
 
 var
   FrmLbxSrch: TFrmLbxSrch;
 
 implementation
 
 {$R *.DFM}
 
 procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char);
 { Помните о том, что свойство KeyPreview должно быть установлено в True }
 var
   curKey: array[0..1] of char;
   ndx: integer;
 begin
   if ActiveControl = ListBox1 then
   begin
     if key = #8 {Backspace (клавиша возврата)} then
     begin
       if FPrefix[0] <> #0 then
       begin
         FPrefix[StrLen(FPrefix) - 1] := #0;
       end
     end
     else
     begin
       curKey[0] := Key;
       curKey[1] := #0;
       StrCat(FPrefix, curKey);
       ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING,
         -1, longint(@FPrefix));
       if ndx <> LB_ERR then
         ListBox1.ItemIndex := ndx;
     end;
 
     Label1.Caption := StrPas(FPrefix);
     Key := #0;
   end;
 end;
 
 procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject);
 begin
   FPrefix[0] := #0;
   Label1.Caption := StrPas(FPrefix);
 end;
 
 end.
 




Поиск значения при вводе

Автор: Bob

Один программист сделал очень эротическую программу с помощью всего лишь быстрого вводa - вывода.

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Первоначально код писался под Delphi 1. Это может и не лучшее решение, но это работает.

Для поиска величины таблица держится открытой. Индекс должен, естественно, принадлежать полю, используемому элементом управления EditBox. В случае изменения содержимого EditBox, новое значение используется для вызова стандартной функции FindNearest таблицы TTable. Возвращаемая величина снова присваивается свойcтву Text элемента EditBox.

Я привел лишь общее решение задачи. Фактически во время изменения значения я включал таймер на период 1/3 секунды и в обработчике события OnTimer проводил операцию поиска (с выключением таймера). Это позволяло пользователю набирать без задержки нужный текст без необходимости производить поиск в расчете на вновь введенный символ (поиск проводился только при возникновении задержки в 1/3 секунды).

Вам также может понадобиться специальный обработчик нажатия клавиши backspace или добавления символа в любое место строки.

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


 procedure Edit1OnChange(...);
 var
   i: integer;
 begin
   if not updating then
     exit;
   {сделайте обновление где-нибудь еще -
   например при срабатывании таймера}
   updating := false;
   Table1.FindNearest([Edit1.text]);
   ListBox1.clear;
   i := 0;
   while (i < 5) and (not (table1.eof)) do
   begin
     listbox.items.add(Table1.fields[0].asString);
     inc(i);
     table1.next;
   end;
   listbox1.itemindex := 0;
 end;
 




Поиск значения при вводе 2

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Это просто. Вот что я написал в обработчике события OnChange редактора.


 with MainForm.PatientTable do
 begin
   { начинаем поиск имени }
   IndexName := 'Name';
   FindNearest([SearchFor.Text]);
 end
 

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




Инкрементация строкового поля

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

Попробуйте это:


 var
   s: string;
 begin
   s := RevField.text;
   s[1] := chr(ord(s[1]) + 1);
   RevField.text := s;
 end;
 

Здесь кроются 2 проблемы:

  1. Для увеличения значения вам необходимо извлекать символы из строки.

  2. Хотя вы можете получить доступ к отдельным символам через выделение подстроки, данный метод не срабатывает у некоторых свойств, таких как, например, свойство TStringField Text.

    Лучшим решением, по-видимому, будет написание специфической функции. Например, в случае, если revision-символ всегда является конечным символом строки, функция могла бы выглядеть следующим образом:


 function IncrementTrailingVersionLetter(Str: string): string;
 begin
   Str[Length(Str)] := Char(Ord(Str[Length(Str)]) + 1);
   IncrementTrailingVersionLetter := Str;
 end;
 

и использовать ее следующим образом:


 with RevField do
   Text := IncrementTrailingVersionLetter(Text);
 




Почему не всегда верно обновляются IndexDefs по Update

Автор: Nomadic

Умер Билл Гейтс, предстал перед архангелом Петром.
- Ну, что скажешь в свое оправдание? - Сурово спросил Петр, покручивая на пальце ключи от Рая.
- Я осчастливил все человечество!
- Это как?! - удивился Петр.
- Ну, так ведь умер!

Ошибка в VCL.
А помогает добавление fUpdated:=false; в теле процедуры TIndexDefs.Update.
Или убиением владельца через Free, и пересозданием.




Обработка исключения index not found

Как мне открыть таблицу dBASE без требуемого MDX-файла? Я постоянно получаю исключение "Index not found..." (индекс не найден).

Во время создания таблицы dBASE с production-индексом (MDX) в заголовке DBF-файла устанавливается специальный байт. При последующем открытии таблицы, dBASE-драйвер читает этот специальный байт и, если он установлен, он также пытается открыть файл MDX. Если попытка открыть файл MDX заканчивается неудачей, возникает исключительная ситуация.

Для решения этой проблемы вам необходимо обнулить этот байт (28-й десятичный байт) в файле DBF, избавляющий таблицу от зависимости MDX-файла.

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


 unit Fixit;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls, DB, DBTables, Grids, DBGrids;
 
 type
 
   TForm1 = class(TForm)
     Table1: TTable;
     ;
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 const
 
   TheTableDir = 'c:\temp\';
   TheTableName = 'animals.dbf';
 
 procedure RemoveMDXByte(dbFile: string);
 { Данная процедура использует в качестве параметра имя файла DBF   }
 { и исправляет его заголовок для того, чтобы не требовать MDX-файл }
 const
 
   Value: Byte = 0;
 var
 
   F: file of byte;
 begin
 
   AssignFile(F, dbFile);
   Reset(F);
   Seek(F, 28);
   Write(F, Value);
   CloseFile(F);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 { Данная процедура вызывается в ответ на нажатие кнопки. Она }
 { пытается открыть таблицу и, если файл .MDX не найден,      }
 { DBF-файл исправляется и управление вновь передается данной }
 { процедуре для повторного открытия таблицы, но уже без MDX  }
 begin
 
   try
     { устанавливаем каталог таблицы }
     Table1.DatabaseName := ThheTableDir;
     { устанавливаем имя таблицы }
     Table1.TableName := TheTableName;
     { пытаемся открыть таблицу }
     Table1.Open;
   except
     on E: EDBEngineError do
       { Нижеследующее сообщение указывает на то, что файл MDX не найден: }
       if Pos('Index does not exist. File', E.Message) > 0 then
       begin
         { Сообщаем пользователю о наличии проблемы. }
         MessageDlg('Файл MDX не найден. Попытка открытия
           без индекса.', mtWarning, [mbOk], 0);
           { удаляем байт MDX из заголовка таблицы }
           RemoveMDXByte(TheTableDir + TheTableName);
           { Посылаем кнопке сообщение для эмуляции ее нажатия. }
           { Этот трюк заставит данную процедуру выполниться    }
           { повторно, и таблица будет открыта без файла MDX    }
           PostMessage(Button1.Handle, cn_Command, bn_Clicked, 0);
       end;
   end;
 end;
 
 end.
 




Косвенный вызов формы

Передаем имя класса формы переменной с именем FormClassName:


 MyForm := TFormClass(FindClass(FormClassName)).Create(Application);
 

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




Добавляем Cookies

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


 procedure TwebDispatcher.WebAction(Sender: TObject; Request: TWebRequest;
   Response: TWebResponse; var Handled: Boolean);
 begin
   with (Response.Cookies.Add) do
   begin
     name := 'TESTNAME';
     Value := 'TESTVALUE';
     Secure := False;
     Expires := Now;
     Response.Cookies.WebResponse.SendResponse;
   end;
 end;
 




Установить соединение с Интернет

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


 unit Unit1;
 
 { This unit shows how you can establish a connection to the internet without any
   user interaction.}
 
 
 interface
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     edtEntry: TEdit;  // holds the name of the connection, e.g. 'bluewin' 
     edtUser: TEdit;   // the username for the above connection 
     edtPass: TEdit;   // and the password 
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 uses shellapi;
 {$R *.dfm}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   cmd, par, fil, dir: PChar;
 begin
   // establish the connection 
   // die Verbindung aufbauen 
   // rasdial.exe entryname username password 
   cmd := 'open';
   fil := 'rasdial.exe';
   par := PChar(edtEntry.Text + ' ' + edtUser.Text + ' ' + edtPass.Text);
   dir := 'C:';
   // call rasdial.exe with Shellexecute 
   // rasdial mit Shellexecute aufrufen 
   ShellExecute(Self.Handle, cmd, fil, par, dir, SW_SHOWMINNOACTIVE);
 end;
 
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   cmd, par, fil, dir: PChar;
 begin
   // disconnect the connection to the Internet 
   // Verbindung zum Internet abbrechen 
   cmd := 'open';
   fil := 'rasdial.exe';
   par := PChar(edtEntry.Text + ' /DISCONNECT');
   dir := 'C:';
   ShellExecute(Self.Handle, cmd, fil, par, dir, SW_SHOWMINNOACTIVE);
 end;
 end.
 




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



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



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


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