Быстрый поиск в базах данных

Я представляю на Ваш суд утилиту быстрого поиска по базе данных. Данная технология производит поиск по полям, преобразуя их значения в строки (все значения преобразуются в верхний регистр, включая действительные числа). Данное решение может быть не самым быстрым, однако на поверку оно оказывается быстрее остальных, обнаруженных мною в Интернете (может вам повезет больше). Более того, представьте, что действительное значение какого-либо поля равно 4.509375354, а значение поиска равно 7, в этом случае утилита засчитает "попадание". Утилита удобна также тем, что она за один проход производит поиск более, чем в одном поле. Это удобно, если у Вас имеются, к примеру, два поля с адресами. Это моя первая "серьезная" разработка, так как первое, с чем я столкнулся, изучая Delphi, стала необходимость включения процедуры поиска в любое приложение, работающее с базой данных. А так как поиск - вещь тоже сугубо специфическая, как и любое приложение, то мне пришлось побороть свой страх перед "крутым программированием" и попробовать написать свой поисковый механизм, удовлетворивший меня (и, надеюсь, других) своей скоростью и возможностью "мульти"-поиска по нескольким полям. Я надеюсь, что он поможет тем программистам, кто часто сталкивается с подобными задачами. Технология довольно легка для понимания, но если у Вас возникли какие-либо вопросы, пошлите мне письмо электронной почтой, я буду рад Вам помочь. Посмотрев код, можно легко узнать поддерживаемые типы полей (добавить новые не составит проблем). Если кто-либо обнаружит ошибочный код или расширит функциональность утилиты, пожалуйста, пошлите это мне, я буду весьма благодарен. Спасибо.

unit Finder; interface uses DB, DBTables, SysUtils; function GrabMemoFieldAsPChar(TheField : TMemoField): PChar; function DoFindIn(TheField : TField; SFor : String): Boolean; function FindIt(TheTable : TDataSet; TheFields : array of integer; SearchBackward : Boolean; FromBeginning : Boolean; SFor : String): Boolean; {применение функции FindIt - if FindIt(NotesSearchT, [NotesSearchT.FieldByName('Leadman').Index], False, True, SearchText.Text) then DoSomething; } implementation function GrabMemoFieldAsPChar(TheField : TMemoField): PChar; begin with TBlobStream.Create(TheField, bmRead) do begin GetMem(Result, Size + 1); FillChar(Result^, Size + 1, #0); Read(Result^, Size); Free; end; end; function DoFindIn(TheField : TField; SFor : String): Boolean; var PChForMemo : PChar; begin Result := False; case TheField.DataType of ftString : begin if (Pos(SFor, UpperCase(TheField.AsString)) > 0) then Result := True; end; ftInteger : begin if (Pos(SFor, TheField.AsString) > 0) then Result := True; end; ftBoolean : begin if SFor = UpperCase(TheField.AsString) then Result := True; end; ftFloat : begin if (Pos(SFor, TheField.AsString) > 0) then Result := True; end; ftCurrency : begin if (Pos(SFor, TheField.AsString) > 0) then Result := True; end; ftDate .. ftDateTime : begin if (Pos(SFor, TheField.AsString) > 0) then Result := True; end; ftMemo : begin SFor[Ord(SFor[0]) + 1] := #0; PChForMemo := GrabMemoFieldAsPChar(TMemoField(TheField)); StrUpper(PChForMemo); if not (StrPos( PChForMemo, @SFor[1] ) = nil) then Result := True; FreeMem(PChForMemo, StrLen(PChForMemo + 1)); end; end; end; function FindIt(TheTable : TDataSet; TheFields : array of integer; SearchBackward : Boolean; FromBeginning : Boolean; SFor : String): Boolean; var i, HighTheFields, LowTheFields : integer; BM : TBookmark; begin TheTable.DisableControls; BM := TheTable.GetBookmark; try LowTheFields := Low(TheFields); HighTheFields := High(TheFields); SFor := UpperCase(SFor); Result := False; if FromBeginning then TheTable.First; if SearchBackward then begin TheTable.Prior; while not TheTable.BOF do begin for i := LowTheFields to HighTheFields do begin if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then begin Result := True; Break; end; end; if Result then Break else TheTable.Prior; end; end else begin TheTable.Next; while not TheTable.EOF do begin for i := LowTheFields to HighTheFields do begin if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then begin Result := True; Break; end; end; if Result then Break else TheTable.Next; end; end; finally TheTable.EnableControls; if not Result then TheTable.GotoBookmark(BM); TheTable.FreeBookmark(BM); end; end; end.

[000030]

FindKey для нескольких полей

with Table1 do begin SetKey; FieldByName('State').AsString := 'CA'; FieldByName('City').AsString := 'Scotts Valley'; GotoKey; end;

Вы не можете использовать Findkey с файлами DBase более чем для одного поля.

oEmetb.indexName:='PrimaryKey'; if oEmeTb.findkey([prCLient,prDiv,prEme])then

где findkey передаются параметры для Primary Keyfields.

Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.

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

oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo'; if oEmeTb.findkey([123,'A',96])then

[001277]

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

Для текста переменной длины вы можете использовать DBmemo. Большинство людей это делают сканированием "на лету" (когда оператор постит запрос), но для реального ускорения процесса можно попробовать способ пре-сканирования, который делают "большие мальчики" (операторы больших баз данных): при внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: "the", "of", "and"])

ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, "hang",46 или "PC",22.

когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, "hang" может возвратить номера записей 11, 46 и 22, тогда как "PC" - записи с номерами 91, 22 и 15.

затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи.

для синонимов определите таблицу синонимов (например, "hang","kaput"), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово.

слова, имеющие общие окончания (например, "hang" и "hanged"), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову "hang" соответствует любое слово, чьи первые 4 буквы равны "hang").

Конечно, есть множестно технических деталей, которые необходимо учесть, например, организация списков, их эффективное управление и объединение. Оптимизация этой характеристики может вам дать очень быстрое время поиска (примером удачный реализаций могут служить двигатели поиска Nexus, Lycos или WebCrawler, обрабатывающие сотни тысяч записей в течение секунды). [001382]

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

Если вы находитесь в режиме редактирования (Edit) или вставки (Insert), то при изменении режима вы автоматически делаете постинг записи. И, естественно, при наличие дубликата (неуникальности) записи, вы получите ошибку. Способ обойти это - использовать другой компонент TTable, связанный с той же таблицей, и осуществляющий по ней поиск. Этот путь самый простой и эффективный.

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

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

Создайте на основе поля первичный индекс (Primary Index). Затем создайте какой-то обработчик DB-исключения для нашего "нарушения уникальности".

Моя технология заключается в следующем: в отдельной форме я предлагаю пользователям ввести часть записи, которая должна быть уникальна (обычно одно поле). Затем для проверки существования я делал FindKey. Если он находился, через MessageDlg я информировал пользователя, и возвращал его на форму редактирования, не создавая новой записи. Помните, что если FindKey ничего не находит, dbCursor никуда не перемещается, и закладка не нужна. Если запись найдена, она немедленно будет отображена на форме редактирования для того, чтобы пользователь смог увидеть ее содержимое. В противном случае происходит следующее:

Table.Append; Table.FieldByName('KeyField').AsString := UserEntry; { ... позволяем пользователю редактировать все остальные поля записи ... } { в это время кнопка Cancel должна быть активной для того, чтобы дать возможность пользователю отменить ввод новой записи. }

В моей форме редактирования поле с уникальном ключем выключается (disabled) и показывается с другим цветом. Целостность соблюдена :-). [001296]

Поиск величины при вводе

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

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

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

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

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

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

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

[000029]

Поиск величины при вводе II

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

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

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

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

//bob [000383]

Поиск записи в больших таблицах

Вот один из советов читателей. Привожу письмо полностью.

Доброго времени суток, Валентин.

Прочитал Ваши "Советы по Delphi" - спасибо большое: понравилось и, главное, помогло - никак не получалось нарисовать круглую форму. В свою очередь хочу предложить на Ваш суд небольшую процедуру, которая мне очень помогла. Процедура позволяет переходить на любую из записей в таблице (формат Paradox или DBase). Необходимость в ней возникла, когда мне пришлось работать с таблицей размером в 10 и более тысяч записей у которой было несколько калькулируемых полей и полей подлинкованных из объектов TQuery. При использовании метода TTable.MoveBy программа медленно и печально замолкала (вообще-то она работала, но как?!). Встретил я этот пример в технической документации Borland (2656), где сравнивались функции Paradox Engine и BDE. Пример был написан на C. Вот его интерпретация на Delphi:

uses ... BDE, DBTables; function MoveToRec(RecNo: longint;taSingle: TDBDataSet): DBIResult; var CursorProps: CurProps; begin Result:= DbiGetCursorProps(taSingle.Handle, CursorProps); if Result = DBIERR_NONE then begin case TTable(taSingle).TableType of ttParadox: Result:= DbiSetToSeqNo(taSingle.Handle,RecNo); ttDBase: Result:= DbiSetToRecordNo(taSingle.Handle,RecNo); else Result:= DBIERR_NOTSUPPORTED; end;{ case..} //------------------------------------ if Result = DBIERR_NONE then taSingle.Resync([rmCenter]); //------------------------------------ end{ if..} end;

С уважением, Александр Куприн. [000226]

Как мне проверить готовность диска 'a:'? I

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

Дополнение от читателя:

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

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

С уважением, Галимарзанов Фанис [000076]

Как мне проверить готовность диска 'a:'? II

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

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

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

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

[000527]

Большие/Маленькие шрифты?

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

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

unit geScale; interface uses Forms, Controls; procedure geAutoScale(MForm: TForm); implementation Type TFooClass = class(TControl); { необходимо выяснить защищенность } { свойства Font } procedure geAutoScale(MForm: TForm); const cScreenWidth :integer = 800; cScreenHeight:integer = 600; cPixelsPerInch:integer= 96; cFontHeight:integer   = -11;  {В режиме проектирование значение из Font.Height} var i: integer; begin { ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE. Следующая программа масштабирует форму так, чтобы она выглядела одинаково внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже участок кода проверяет, отличается ли размер экрана во время выполнения от размера во время проектирования. Если да, Scaled устанавливается в True и компоненты снова масштабируются так, чтобы они выводились в той же позиции экрана, что и во время проектирования. } if (Screen.width &;lt> cScreenWidth)or(Screen.PixelsPerInch <> cPixelsPerInch) then begin MForm.scaled := TRUE; MForm.height := MForm.height * screen.Height DIV cScreenHeight; MForm.width  := MForm.width  * screen.width DIV cScreenWidth; MForm.ScaleBy(screen.width, cScreenWidth); end; { Этот код проверяет, отличается ли размер шрифта во времы выполнения от размера во время проектирования. Если во время выполнения pixelsperinch формы отличается от pixelsperinch во время проектирования, шрифты снова масштабируются так, чтобы форма не отличалась от той, которая была во время разработки. Масштабирование производится исходя из коэффициента, получаемого путем деления значения font.height во время проектирования на font.height во время выполнения. Font.size в этом случае работать не будет, так как это может дать результат больший, чем текущие размеры компонентов, при этом текст может оказаться за границами области компонента. Например, форма создана при размерах экрана 800x600 с установленными маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете в системе с 800x600 и большими шрифтами, font.size также будет равен 8, но текст будет бОльшим чем при работе в системе с маленькими шрифтами. Данное масштабирование позволяет иметь один и тот же размер шрифтов при различных установках системы. } if (Screen.PixelsPerInch <> cPixelsPerInch) then begin for i := MForm.ControlCount - 1 downto 0 do TFooClass(MForm.Controls[i]).Font.Height := (MForm.Font.Height div cFontHeight) * TFooClass(MForm.Controls[i]).Font.Height; end; end; end.

[000282]

Хранение стилей шрифта

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,

Var Style   : TFontStyles; begin { Сохраняем стиль шрифта в байте } Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство} ByteValue := Byte ( Style ); { Преобразуем значение byte в TFontStyles } Canvas.Font.Style := TFontStyles ( ByteValue ); end;

Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.

- Robert Wittig [001117]

Изменение стиля шрифта

Попробуйте следующий код... это должно работать:

with cp do begin { устанавливаем различные атрибуты } Font.Style := Font.Style + [fsStrikeOut];  { для добавления стиля strike (зачеркивание) } Font.Style := Font.Style - [fsStrikeOut];   { для выключения эффекта зачеркивания } end;

Замечание: данный метод будет работать также и для изменения атрибутов Bold, Italic и Underline. [001998]

Как добавить шрифт в Windows 95/98?

Своим опытом делится Олег Кулабухов:

Для начала нужно скопировать шрифт в системную папку Windows\Fonts. Затем добавить соответствующее значение в реестр "'Software\Microsoft\Windows\CurrentVersion\Fonts", выполнить функцию AddFontRecource() и передать сообщение WM_FONTCHANGE. Затем выполнить RemoveFontRecource() для снятия залочки с ситемного ресурса и выполнить второй посыл сообщения WM_FONTCHANGE.

uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; b : bool; begin CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b); reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false); reg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); reg.CloseKey; reg.free; {Add the font resource} AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); {Remove the resource lock} RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end;

[001880]

Как определить, большие или маленькие шрифты используются в системе?

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

FUNCTION SmallFonts : BOOLEAN; {возвращает TRUE если установлены маленькие шрифты и FALSE если большие } VAR DC : HDC; { используется для проверки количества доступных цветов } BEGIN DC := GetDC(0); Result :=   (GetDeviceCaps(DC, LOGPIXELSX) = 96); { Если используются большие шрифты, LOGPIXELSX будет равен 120 } ReleaseDC(0, DC); END;

[000281]

Как приложению воспользоваться своими шрифтами? Без помощи пользователя

Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.

Ниже приведен код для Delphi 1, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.

Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.

type TForm1=class( TForm ) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); ... private { Private declarations } bLoadedFont: boolean; public { Public declarations } end; procedure TForm1.FormCreate(Sender: TObject); var sAppDir: string; sFontRes: string; begin sAppDir := Application.ExeName; sAppDir := copy( sAppDir, 1, rpos( '\', sAppDir ) ); sFontRes := sAppDir + 'MYFONT.FOT'; if not FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; sFont := sAppDir + 'MYFONT.TTF' + #0; CreateScalableFontResource( 0, @sFontRes[ 1 ], @sFont[ 1 ], nil ); end; sFontRes := sAppDir + 'MYFONT.FOT'; if FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; ... end; procedure TForm1.FormDestroy(Sender: TObject); var sFontRes: string; begin if bLoadedFont then begin sFontRes := sAppDir + 'MYFONT.FOT' + #0; RemoveFontResource( @sFontRes[ 1 ] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end;

Я поработал с данным кодом и внес некоторые поправки для корректной работы на Delphi 2.0. На Delphi 3.0 не испытано.

Электронная справка по продукту InstallShield показывает, что в системах Win95 и WinNT FOT-файл не нужен. Вам нужен только TTF-файл.

В результате процедура FormCreate стала выглядеть так:

var sAppDir, sFontRes: string; begin {...другой код...} sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF'; if FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; end; {...} end; {FormCreate}

А FormDestroy так:

var sFontRes, sAppDir: string; begin {...другой код...} if bLoadedFont then begin sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF' + #0; RemoveFontResource( @sFontRes[ 1 ] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; {...другой код...} end; {FormDestroy}

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

{1998-01-16 Функция загрузки и выгрузки шрифта.} function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean; var sFont, sAppDir, sFontRes: string; begin result := TRUE; if bLoadIt then begin {Загрузка шрифта.} if FileExists( sFontFileName ) then begin sFontRes := sFontFileName + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then result := FALSE else SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end else begin {Выгрузка шрифта.} sFontRes := sFontFileName + #0; result := RemoveFontResource( @sFontRes[1] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; {LoadFont}

Дополнение

Nomadic предлагает следующее решение:

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно следующим образом:

{$IFDEF WIN32} AddFontResource( PChar( my_font_PathName { AnsiString } ) ); {$ELSE} var ss : array [ 0..255 ] of Char; AddFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF} SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

Убрать его по окончании работы:

{$IFDEF WIN32} RemoveFontResource ( PChar(my_font_PathName) ); {$ELSE} RemoveFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF} SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 )

При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName: string ( не string[nn] для D2 и выше) - содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным. В любом случае я это не проверял. [000090]

Каким обpазом выбиpать pазмеp

Из советов Nomadic'a:

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC( pData: Pointer ) //void GLSetupRC(void *pData) //{ var //  HDC hDC; hDC: HDC; //  HFONT hFont; hFont: HFONT; //  GLYPHMETRICSFLOAT agmf[128]; agmf: array [0..127] of GLYPHMETRICSFLOAT; //  LOGFONT logfont; logfont: LOGFONT; begin logfont.lfHeight := -10; logfont.lfWidth := 0; logfont.lfEscapement := 0; logfont.lfOrientation := 0; logfont.lfWeight := FW_BOLD; logfont.lfItalic := FALSE; logfont.lfUnderline := FALSE; logfont.lfStrikeOut := FALSE; logfont.lfCharSet := ANSI_CHARSET; logfont.lfOutPrecision := OUT_DEFAULT_PRECIS; logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS; logfont.lfQuality := DEFAULT_QUALITY; logfont.lfPitchAndFamily := DEFAULT_PITCH; //strcpy(logfont.lfFaceName,"Arial"); //  strcpy(logfont.lfFaceName,"Decor"); StrPCopy( logfont.lfFaceName, 'Decor' ); glDepthFunc(GL_LESS); glEnable(GL_DEPTH_TEST);  // Hidden surface removal glFrontFace(GL_CCW);      // Counter clock-wise polygons face out glEnable(GL_CULL_FACE);   // Do not calculate insides glShadeModel(GL_SMOOTH);  // Smooth shading glEnable(GL_AUTO_NORMAL); glEnable(GL_NORMALIZE); glEnable(GL_COLOR_MATERIAL); glClearColor(0.0, 0.0, 0.0, 1.0 ); glEnable(GL_LIGHTING); glLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight); glLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight); glLightfv(GL_LIGHT0,GL_SPECULAR,specular); glLightfv(GL_LIGHT0,GL_POSITION,lightPos); glEnable(GL_LIGHT0); glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE); glMaterialfv(GL_FRONT, GL_SPECULAR,specular); glMateriali(GL_FRONT,GL_SHININESS,100); // Blue 3D Text glRGB(0, 0, 255); // Select the font into the DC hDC := (HDC)pData; //  hFont = CreateFontIndirect(&logfont); hFont := CreateFontIndirect( Addr(logfont) ); SelectObject (hDC, hFont); //create display lists for glyphs 0 through 255 with 0.3 extrusion // and default deviation. The display list numbering starts at 1000 // (it could be any number). //  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, //                            WGL_FONT_POLYGONS, agmf)) if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, //>                                         ``` - это тебе поможет //> Выводить текст можно в любым масштабе WGL_FONT_POLYGONS, agmf) then Windows.MessageBox(nil,'Could not create Font Outlines', 'Error',MB_OK or MB_ICONSTOP); // Delete the font now that we are done DeleteObject(hFont); //} end; // void GLRenderScene(void *pData) procedure GLRenderScene(pData: Pointer); begin (*  ...  *) // Draw 3D text glListBase(1000); glPushMatrix(); // Set up transformation to draw the string. glTranslatef(-35.0, 0.0, -5.0) ; glScalef(60.0, 60.0, 60.0); glCallLists(3, GL_UNSIGNED_BYTE, 'Decor'); glPopMatrix();  // Clear the window with current clearing color (* ... *) end;

[001595]

Переключение с 96DPI на 120DPI

Вы серьезно предлагаете мне, для того, чтобы получить профессиональный результат, разрабатывать свои формы в этом системном разрешении?

Нет, конечно нет. Масштабирование Delphi кажется работает не хуже, чем стандартный диалог масштабирования Windows. Правда, результат иногда получается просто безобразным. Я думаю, главная проблема здесь в размере шрифтов: когда вы переключаетесь с 96DPI на 120DPI, размеры шрифта изменяются. Но мне, правда, повезло: в моей 96DPI-форме я использовал шрифт размером 10 точек, а при 120DPI он превратился в 8-точечный. Итак, мои предложения:

Попробуйте использовать растровые шрифты, поскольку они масштабируются наиболее качественно Используйте шрифты TrueType, которые вообще не имеют проблем масштабирования [000320]

PopupComponent и шрифты

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

Хитрость заключается в создании в вашей секции implementation следующего описания класса:

type THack = class(TControl) public property Font; end;

затем ваш код может выглядеть приблизительно так:

if Popup1.PopupControl is TControl then if FontDialog1.Execute then THack(Popup1.PopupControl).Font := FontDialog1.Font;

- Pat Ritchey [000965]

Проверка шрифта с фиксированной шириной

Посмотрите в библиотеке console.zip от Danny Thorpe -- он проверяет, является ли шрифт шрифтом с фиксированной шириной. Вот код, который делает это:

procedure TConsole.FontChanged(Sender: TObject); var DC: HDC; Save: THandle; Metrics: TTextMetric; Temp: String; begin if Font.Handle <> FOldFont.Handle then begin DC := GetDC(0); Save := SelectObject(DC, Font.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, Save); ReleaseDC(0, DC); if not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and ((Metrics.tmPitchAndFamily and $01) = 0)) then begin Temp := 'TConsole: ' + Font.Name + ' не является шрифтом с фиксированной шириной'; Font.Name := FOldFont.Name;  { Возвращаем предыдущие атрибуты шрифта } raise EInvalidFont.Create(Temp); end; SetMetrics(Metrics); end; FOldFont.Assign(Font); if csDesigning in ComponentState then InternalClrScr; end;

Andy King. [000728]

Различные разрешения - различные размеры шрифтов

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

Свойство, отвечающее за размер шрифта важно, но не менее важны в этом вопросе и другие характеристики. Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела.

Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif.

У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал.

Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).

В целом же, завершая рассказ, следует подчеркнуть, что выключенное свойство scaling и использование пикселей вместо точек для изменения размеров шрифта, дает вполне приемлимый результат. [001744]

Размер масштабированного шрифта

При Scaling = False, Delphi не пытается изменить размер окна и элементов управления, использующих системные шрифты. Если элементы управления используют системный шрифт, размер текста не изменяется.

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

Попробуйте использовать шрифт TrueType, скажем Arial вместо MS Sans Serif, но будьте внимательны, при этом приложением игнорируется смена пользователем маленких/больших шрифтов в Панели Управления.

Как известно, пользователю легче пользоваться диалогами с маленькими шрифтами, чем глядеть все время на большой текст. [000322]

Свойства шрифта Style/Color в виде строки

Как мне получить значение Font.Style и Font.Color в виде строки, я хотел бы присвоить его заголовку компонента Label, но style и color не являются строковыми величинами.

Есть масса способов это сделать, но я использую следующий способ:

const fsTextName: array[TFontStyle] of string[11] = ('fsBold', 'fsItalic', 'fsUnderline', 'fsStrikeOut'); fpTextName: array[TFontPitch] of string[10] = ('fpDefault','fpVariable','fpFixed');

Позже, в коде, я так использую эти имена:

var TFPitch: TFontPitch; TFStyle: TFontStyle; FString: String; FString := ''; for TFStyle := fsBold to fsStrikeOut do if TFStyle in Canvas.Font.Style then Fstring := Fstring+fsTextName[TFStyle]+','; if FString<>'' then dec(FString[0]); { убираем лишний разделитель ',' } something := FString; FString := fpTextName[Canvas.Font.Pitch]; something := FString;

Примерно также нужно поступить и с именованными цветами типа TColor.

- Dennis Passmore [000850]

Управление настройками шрифта

{ Данный код изменяет стиль шрифта поля редактирования, если оно выбрано. Может быть адаприрован для управления шрифтами в других объектах. Расположите на форме Edit(Edit1) и ListBox(ListBox1). Добавьте следующие элементы (Items) к ListBox: fsBold fsItalic fsUnderLine fsStrikeOut } procedure TForm1.ListBox1Click(Sender: TObject); var X : Integer; type TLookUpRec = record Name: String; Data: TFontStyle; end; const LookUpTable: array[1..4] of TLookUpRec = ((Name: 'fsBold'; Data: fsBold), (Name: 'fsItalic'; Data: fsItalic), (Name: 'fsUnderline'; Data: fsUnderline), (Name: 'fsStrikeOut'; Data: fsStrikeOut)); begin X := ListBox1.ItemIndex; Edit1.Text := ListBox1.Items[X]; Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex+1].Data]; end;

[001487]

Включение шрифта как ресурс в *.EXE

Включение шрифта в ваш EXE:

Используйте ваш любимый текстовый редактор, создайте *.rc файл, описывающий шрифт:

MY_FONT ANYOL1 &quotBauhs93.ttf&quot

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

Затем для создания *.res файла используйте компилятор командной строки BRCC32.EXE, поставляемый с Delphi. Если ваш файл на этапе 1 был назван MyFont.rc, командная строка в сеансе DOS должна выглядеть так:

BRCC32 MyFont

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

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

{$R MyFont.res}

Правильным будет разместить его в секции реализации после строчки {$R *.DFM}.

Добавьте процедуру создания файла из ресурса, делающим шрифт доступным для использования. Пример:

procedure TForm1.FormCreate(Sender: TObject); var Res : TResourceStream; begin Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1')); Res.SavetoFile('Bauhs93.ttf'); Res.Free; AddFontResource(PChar('Bauhs93.ttf')); SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end;

Теперь вы можете использовать данный шрифт в своем приложении:

procedure TForm1.Button1Click(Sender: TObject); begin Button1.Font.Name := 'Bauhaus 93'; end;

Предостережения:

Приведенный пример не предусматривает никакой проверки и защиты от возможных ошибок.

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

Я рекомендую устанавливать файл шрифта в папку C:\WINDOWS\FONTS. Его легче отыскать потом именно там.

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

procedure TForm1.FormDestroy(Sender: TObject); begin RemoveFontResource(PChar(&quotBauhs93.ttf&quot)) SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end;

Для получения дополнительной справки по функциям AddFontResource и RemoveFontResource загляните в электронную справку по Win32. [000091]

UUE кодирование

Sergei Dubarev пишет:

Ваши "Советы..." - классная штука. Столько всего вкусного! :-) Со своей стороны хочу предложить несколько тормозной и местами упрощенный, но все же рабочий ;), алгоритм UUE кодирования (см. аттач). Не вершина искусства, но все же... :)

Для того, чтобы ОНО заработало, необходимо создать проект в составе: Форма (form) - 1 шт. Поле ввода (edit) - 2 шт., используются события OnDblClick. Кнопка (button) - 1 шт., используется событие OnClick. Диалог открытия файла (Open Dialog) - 1 шт. Диалог сохранения файла (Save Dialog) - 1 шт. Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE."

Всего хорошего.

P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.

P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.

Файл Unit1.pas

//UUE кодирование unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtDlgs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; Edit2: TEdit; OpenDialog1: TOpenDialog; SaveDialog1: TSaveDialog; procedure Edit1DblClick(Sender: TObject); procedure Edit2DblClick(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const ssz = (High(Cardinal) - $F) div sizeof(byte); //эта константа используется при выделении памяти p:    string= '0123456789ABCDEF'; //эта константа используется функцией toanysys //выбор входного файла procedure TForm1.Edit1DblClick(Sender: TObject); begin if opendialog1.execute then edit1.text:= opendialog1.filename; end; //выбор выходного (UUE) файла procedure TForm1.Edit2DblClick(Sender: TObject); begin if savedialog1.execute then edit2.text:= savedialog1.filename; end; //выделение подстроки function mid(s: string; fromc, toc: byte): string; var s1: string; i : byte; begin s1:= ''; for i:= fromc to toc do s1:= s1+s[i]; mid:= s1; end; //перевод числа (a) из десятичной системы в другую //с основанием (r) function toanysys(a, r: byte): string; var s, k : string; n, m, i : byte; begin s:=''; m:= 1; while m<>0 do begin m:= a div r; n:= a-m*r+1; k:= p[n]; s:= k+s; a:= m; end; //добавляет незначащие нули for i:=1 to 8-length(s) do s:='0'+s; toanysys:= s; end; //перевод 6-разрядного числа из двоичной системы в десятичную //двоичное число подставляется в виде строки символов function frombin(s: string): byte; var i, e, b: byte; begin b:= 0; for i:=1 to 6 do begin e:= 1 shl (6-i); if s[i]='1' then b:= b+e; end; frombin:= b; end; //непосредственно кодирование type tcoola = array [1..1] of byte; pcoola = ^tcoola; procedure TForm1.Button1Click(Sender: TObject); var inf: file of byte; ouf: textfile; uue: pcoola; b  : array[1..4] of byte; bin, t  : string; szf, oum, szl, szh, sxl, sxh, i  , j  : longint; begin {$I-} assignfile(inf, edit1.text); //входной файл reset(inf); szf:= filesize(inf);    // szh:= (szf*8) div 6;    // if szf*8-szh*6 = 0 then szl:= 0 else szl:= 1;      // getmem(uue, szh+szl); //выделение памяти oum:= 1; while not(eof(inf)) do begin b[1]:= 0; b[2]:= 0; b[3]:= 0; b[4]:= 0; //чтение должно быть сделано посложнее, //дабы избежать "read beyond end of file" read(inf, b[1], b[2], b[3]); //читаем 3 байта из входного файла //и формируем "двоичную" строку bin:= toanysys(b[1],2)+ toanysys(b[2],2)+ toanysys(b[3],2); //разбиваем строку на куски по 6 бит и добавляем 32 t:= mid(bin, 19, 24); b[4]:= frombin(t)+32; t:=mid(bin, 13, 18); b[3]:= frombin(t)+32; t:= mid(bin, 07, 12); b[2]:= frombin(t)+32; t:= mid(bin, 01, 06); b[1]:= frombin(t)+32; //запихиваем полученнные байты во временный массив uue[oum]:= b[1]; oum:= oum+1; uue[oum]:= b[2]; oum:= oum+1; uue[oum]:= b[3]; oum:= oum+1; uue[oum]:= b[4]; oum:= oum+1; end; //входной файл больше не нужен - закрываем его closefile(inf); //формируем выходной файл assignfile(ouf, edit2.text); //выходной файл rewrite(ouf); oum:= 1; sxh:= (szh+szl) div 60; //число строк в UUE файле sxl:= (szh+szl)-sxh*60; //заголовок UUE-файла writeln(ouf, 'begin 644 '+extractfilename(edit1.text)); //записываем строки в файл for i:=1 to sxh do begin write(ouf, 'M'); // 'M' значит, что в строке 60 символов for j:= 1 to 60 do begin write(ouf, chr(uue[oum])); oum:= oum+1; end; writeln(ouf); end; //записываем последнюю строку, которая //обычно короче 60 символов sxh:= (sxl*6) div 8; write(ouf, chr(sxh+32)); for i:= 1 to sxl do begin write(ouf, chr(uue[oum])); oum:= oum+1; end; // "добиваем" строку незначащими символами for i:= sxl+1 to 60 do write(ouf, '`'); //записываем последние строки файла writeln(ouf); writeln(ouf, '`'); writeln(ouf, 'end'); closefile(ouf); freemem(uue, szh+szl); //освобождаем память showmessage('DONE.'); //Готово. Забирайте! end; end.

Из FIDO-переписки: - New auto-created HomeNet area (555:172/89.2) ------------- HOME.PROGRAMMERS - Msg : 34 of 35 From : Philip Bondarovich 555:172/445.43 Пнд 17 Янв 00 02:51 To : Denis Guravski Втp 18 Янв 00 22:21 Subj : UUE ------------------------------------------------------------------------------- Wednesday January 12 2000 22:56, Denis Guravski писал All: DG> Люди , сpочно нyжно описание сабжа . === Begin uuecode === - INT.PROGRAMMERS (256:172/43) ------------------------------ INT.PROGRAMMERS - Msg : 38 of 38 -36 Scn From : Monk 256:172/10 15 Jan 00 18:24:30 To : Nikolay Severikov 16 Jan 00 03:47:50 Subj : UU-code ------------------------------------------------------------------------------- Жывi сабе памаленькy, /_*Nikolay*_/! У чацьвэp Стyдзеня 13 2000 y 23:25, цёмнай ночкаю, Nikolay Severikov тайна пiсаў All, i я ўцягнyўся... NS> Расскажите плиз о сyбже... Как он кодиpyется. Калi ласка. === Cut === 1) Читаем из исходного хфайла 3 байта. 2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит. 3) Добавляем к каждой части число 32 (десятичн.) Пpимеp: Имеем тpи числа 234 12 76. Побитово бyдет так - 11101010 00001100 01001100 pазбиваем и полyчаем - 111010 100000 110001 001100 добавляем 32 - +100000 +100000 +100000 +100000 ------ ------ ------ ------ 1011010 1000000 1010001 101100 или в бyквах - Z @ Q , Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во. Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения 60 символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит бyква "M", а ее ASCII код = 77. 45+32=77. === Cut === З павагай да ўсiх вас, Monk. Спадзяюся на пpацяг pазмовы, *Nikolay*! ... -Папа, я есть хочy! -Стыдись, сынок, в твои годы я хотел стать космонавтом! -+- GoldED+/386 1.1.1.2 + Origin: - Тавеpна BBS - 241-5714 23:00-6:00. Freqs allowed. (256:172/10) === End uuecode === WBR. ... Чешиpский Котенок лyчше всех --- GoldED+/W32 1.1.1.2 * Origin: WonderLand (555:172/445.43) [001078]

Цветное изображение из res-файла

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

function LoadBitmap256( hInstance: HWND; lpBitmapName: PChar ): HBITMAP; var hPal, hRes, hResInfo: THandle; pBitmap: PBitmapInfo; nColorData: Integer; pPalette: PLogPalette; X: Integer; hPalette: THandle; begin hResInfo     := FindResource( hInstance, lpBitmapName, RT_BITMAP ); hRes         := LoadResource( hInstance, hResInfo ); pBitmap      := Lockresource( hRes ); nColorData   := pBitmap^.bmiHeader.biClrUsed; hPal := GlobalAlloc( GMEM_MOVEABLE, ( 16 * nColorData ) ); {  hPal := GlobalAlloc( GMEM_MOVEABLE, ( SizeOf( LOGPALETTE ) + (nColorData * SizeOf( PALETTEENTRY )));} pPalette := GlobalLock( hPal ); pPalette^.palVersion := $300; pPalette^.palNumEntries := nColorData; for x := 0 to nColorData do begin pPalette^.palPalentry[X].peRed   := pBitmap^.bmiColors[X].rgbRed; pPalette^.palPalentry[X].peGreen := pBitmap^.bmiColors[X].rgbGreen; pPalette^.palPalentry[X].peBlue  := pBitmap^.bmiColors[X].rgbBlue; end; hPalette := CreatePalette( pPalette^ ); GlobalUnlock( hRes ); GlobalUnlock( hPal ); GlobalFree( hPal ); end; end.

- Mark Lussier [001047]

Bitmap без формы

Как мне загрузить изображение (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 реализует для вас нужную палитру.

- Mike Scott [000910]

Bitmap.Scanline для PixelFormat=pf1bit, pf8bit, pf24bit

(Техника программирования в Delphi 3)

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

Общее

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

Возможные PixelFormats включают: pfDevice pf1bit pf4bit pf8bit pf15bit pf16bit pf24bit 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.

[000123]

Delphi и графика

Если вам нужно просто вывести одно изображение, создайте объект TBitmap, "поиграйтесь" с ним, а когда изображение будет готово появиться на экране, вызовите функцию Image.Canvas.Draw(0, 0, Bitmap), которая скопирует и нарисует его на экране. Как вы наверное заметили, основное время занимает рисование картинки на экране, а не установка ее атрибутов. В результате мы устанавливаем цвета на невидимом объекте (TBitmap мы уже создали), и отображаем только полностью готовый Bitmap. Вот демонстрационный код для формы с единственным на ней компонентом Image:

procedure TForm1.FormPaint(Sender: TObject); Var TmpX, TmpY : Byte; MyImage : TBitmap; begin Form1.Width := 260;    Form1.Height := 260; Image1.Width := 250;   Image1.Height := 250; Image1.top := 5;       Image1.width := 5; MyImage := TBitmap.Create; MyImage.Width := 250;  MyImage.Height := 250; FOR TmpX := 0 TO 249 DO FOR TmpY := 0 TO 249 DO MyImage.Canvas.Pixels[TmpX,TmpY] := RGB(TmpX, 250 - TmpY, (TmpX + TmpY DIV 2)); Image1.Canvas.Draw(0, 0, MyImage); MyImage.Free; end;

Если вы хотите сделать действительно быструю графику, взгляните на функции GDI (API) и/или функции WinG, которые для вас разработали программисты Microsoft. Трактовка их для данной статьи немного скучна, да и не имеет никакого отношения к Delphi. [001808]

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

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

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

Данный пример помещает вашу запись в объект. Хотя это и не было строго необходимым, я сконфигурировал алгоритм имеенно так, потому что рано или поздно вы это сделаете... В качестве средства для чтения и записи он использует потоки. Возможно вы уже использовали потоки, поэтому моя технология не будет для вас открытием. Одно из преимуществ использования потока в том, что для работы с графическими объектами -- 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.

- Ed Jordan [000974]

Функция для работы с палитрами и RGB

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

При работе с палитрами рекомендуется пользоваться функцией RGB. Если вы используете ее для изменения свойства "Color", Windows довольно хорошо справляется с задачай подбора цветов для низкого разрешения, а в системах с высоким разрешением вы получите точный цвет RGB. Это могло бы послужить выходом из создавшейся у вас ситуации. Вот пример формы, которая "линяет" от красного до синего:

procedure TForm1.FormClick(Sender: TObject); var blue : Byte; begin For blue := 0 to 255 do Begin Color := RGB(255-blue,0,blue); Update; End; end;

[000689]

Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки

Публикую полностью работу Den is Com. Основана на коде модуля gblur2 из предыдущего совета:

Данный метод позволяет создавать тень у текстовых меток TLabel. Не требует лазить в Photoshop и что-то ваять там - тень рисуется динамически, поэтому и объём программы не раздувает. Создание тени присходит в фоновом режиме, во время "простоя" процессора.

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

ShowFade(CaptionLabel); //или ShowFadeWithParam(CaptionLabel,3,3,2,clGray);

Blur.pas

unit blur; interface uses Classes,graphics,stdctrls,gblur2; const add_width=4; add_height=5; type TBlurThread = class(TThread) private { Private declarations } text_position:Integer; FadeLabel:TLabel; Temp_Bitmap:TBitmap; procedure ShowBlur; procedure SetSize; protected F_width,F_X,F_Y:Integer; F_color:TColor; procedure Execute; override; public constructor Create(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor); destructor  Destroy; end; procedure ShowFade(Sender:TLabel); procedure ShowFadeWithParam(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor); implementation procedure ShowFadeWithParam(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor); var SlowThread:TBlurThread; begin SlowThread:=TBlurThread.Create(Sender,Fade_width,Fade_X,Fade_Y,Fade_color); SlowThread.Priority:=tpIdle; SlowThread.Resume; end; procedure ShowFade; var SlowThread:TBlurThread; begin SlowThread:=TBlurThread.Create(Sender,3,3,3,clBlack); SlowThread.Priority:=tpIdle; //SlowThread.Priority:=tpLowest; //SlowThread.Priority:=tpTimeCritical; SlowThread.Resume; end; constructor TBlurThread.Create(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor); begin Temp_Bitmap:=TBitmap.Create; Temp_Bitmap.Canvas.Font:=Sender.Font; FadeLabel:=Sender; F_width:=Fade_width; F_X:=Fade_X; F_Y:=Fade_Y; F_color:=Fade_color; inherited Create(True); end; destructor TBlurThread.Destroy; begin Temp_Bitmap.Free; inherited Destroy; end; procedure TBlurThread.ShowBlur; begin FadeLabel.Canvas.Draw(text_position+F_X,F_Y,Temp_Bitmap); FadeLabel.Canvas.TextOut(text_position,0,FadeLabel.Caption); end; procedure TBlurThread.SetSize; begin if FadeLabel.Width<(Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)+F_width+F_X{add_width}) then begin FadeLabel.Width:=Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)+F_width+F_X{add_width}; FadeLabel.Tag:=2; end else FadeLabel.Tag:=0; if FadeLabel.Height<(Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption)+F_width+F_Y{add_height}) then begin FadeLabel.Height:=Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption)+F_width+F_Y{add_height}; FadeLabel.Tag:=1; end else if FadeLabel.Tag<>2 then FadeLabel.Tag:=0; end; { TBlurThread } procedure TBlurThread.Execute; begin { Place thread code here } Synchronize(SetSize); if FadeLabel.Tag=0 then begin Temp_Bitmap.Width:=FadeLabel.Width; Temp_Bitmap.Height:=FadeLabel.Height; Temp_Bitmap.Canvas.Brush.Color:=FadeLabel.Color; Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect); Temp_Bitmap.Canvas.Font.Color:=F_color; //clBlack if FadeLabel.Alignment=taRightJustify then text_position:=FadeLabel.Width-Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)-F_width-F_X{add_width} else if FadeLabel.Alignment=taCenter then text_position:=(FadeLabel.Width-Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)-F_width-F_X{add_width}) div 2 else text_position:=0; Temp_Bitmap.Canvas.TextOut(0,0,FadeLabel.Caption); Temp_Bitmap.PixelFormat:= pf24Bit; GBlur(Temp_Bitmap,F_width); //Temp_Bitmap.SaveToFile('a.bmp'); Synchronize(ShowBlur); end; end; end.

[000814]

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

Ядро гауссовой функции exp(-(x^2 + y^2)) есть разновидность формулы f(x)*g(y), которая означает, что мы можем выполнить двумерную свертку, делая последовательность одномерных сверток - сначала мы свертываем каждую строчку изображения, затем - каждую колонку. Хороший повод для ускорения (N^2 становится N*2). Любая свертка требует некоторого место для временного хранения результатов - ниже в коде программа BlurRow как раз распределяет и освобождает память для каждой колонки. Вероятно это должно ускорить обработку изображения, правда не ясно насколько.

Поле "size" в записи TKernel ограничено значением 200. Фактически, если вы хотите использовать еще больший радиус, это не вызовет проблем - попробуйте со значениями radius = 3, 5 или другими. Для большого количества данных методы свертки на поверку оказываются эффективнее преобразований Фурье (как показали опыты).

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

Во всяком случае вы можете сделать так:

unit GBlur2; interface uses Windows, Graphics; type PRGBTriple = ^TRGBTriple; TRGBTriple = packed record b: byte; //легче для использования чем типа rgbtBlue... g: byte; r: byte; end; PRow = ^TRow; TRow = array[0..1000000] of TRGBTriple; PPRows = ^TPRows; TPRows = array[0..1000000] of PRow; const MaxKernelSize = 100; type TKernelSize = 1..MaxKernelSize; TKernel = record Size: TKernelSize; Weights: array[-MaxKernelSize..MaxKernelSize] of single; end; //идея заключается в том, что при использовании TKernel мы игнорируем //Weights (вес), за исключением Weights в диапазоне -Size..Size. procedure GBlur(theBitmap: TBitmap; radius: double); implementation uses SysUtils; procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double); //Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius. //Для текущего приложения мы устанавливаем переменные MaxData = 255, //DataGranularity = 1. Теперь в процедуре установим значение //K.Size так, что при использовании K мы будем игнорировать Weights (вес) //с наименее возможными значениями. (Малый размер нам на пользу, //поскольку время выполнения напрямую зависит от //значения K.Size.) var j: integer; temp, delta: double; KernelSize: TKernelSize; begin for j:= Low(K.Weights) to High(K.Weights) do begin temp:= j/radius; K.Weights[j]:= exp(- temp*temp/2); end; //делаем так, чтобы sum(Weights) = 1: temp:= 0; for j:= Low(K.Weights) to High(K.Weights) do temp:= temp + K.Weights[j]; for j:= Low(K.Weights) to High(K.Weights) do K.Weights[j]:= K.Weights[j] / temp; //теперь отбрасываем (или делаем отметку "игнорировать" //для переменной Size) данные, имеющие относительно небольшое значение - //это важно, в противном случае смазавание происходим с малым радиусом и //той области, которая "захватывается" большим радиусом... KernelSize:= MaxKernelSize; delta:= DataGranularity / (2*MaxData); temp:= 0; while (temp < delta) and (KernelSize > 1) do begin temp:= temp + 2 * K.Weights[KernelSize]; dec(KernelSize); end; K.Size:= KernelSize; //теперь для корректности возвращаемого результата проводим ту же //операцию с K.Size, так, чтобы сумма всех данных была равна единице: temp:= 0; for j:= -K.Size to K.Size do temp:= temp + K.Weights[j]; for j:= -K.Size to K.Size do K.Weights[j]:= K.Weights[j] / temp; end; function TrimInt(Lower, Upper, theInteger: integer): integer; begin if (theInteger <= Upper) and (theInteger >= Lower) then result:= theInteger else if theInteger > Upper then result:= Upper else result:= Lower; end; function TrimReal(Lower, Upper: integer; x: double): integer; begin if (x < upper) and (x >= lower) then result:= trunc(x) else if x > Upper then result:= Upper else result:= Lower; end; procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow); var j, n, LocalRow: integer; tr, tg, tb: double; //tempRed и др. w: double; begin for j:= 0 to High(theRow) do begin tb:= 0; tg:= 0; tr:= 0; for n:= -K.Size to K.Size do begin w:= K.Weights[n]; //TrimInt задает отступ от края строки... with theRow[TrimInt(0, High(theRow), j - n)] do begin tb:= tb + w * b; tg:= tg + w * g; tr:= tr + w * r; end; end; with P[j] do begin b:= TrimReal(0, 255, tb); g:= TrimReal(0, 255, tg); r:= TrimReal(0, 255, tr); end; end; Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple)); end; procedure GBlur(theBitmap: TBitmap; radius: double); var Row, Col: integer; theRows: PPRows; K: TKernel; ACol: PRow; P:PRow; begin if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then raise exception.Create('GBlur может работать только с 24-битными изображениями'); MakeGaussianKernel(K, radius, 255, 1); GetMem(theRows, theBitmap.Height * SizeOf(PRow)); GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple)); //запись позиции данных изображения: for Row:= 0 to theBitmap.Height - 1 do theRows[Row]:= theBitmap.Scanline[Row]; //размываем каждую строчку: P:= AllocMem(theBitmap.Width*SizeOf(TRGBTriple)); for Row:= 0 to theBitmap.Height - 1 do BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P); //теперь размываем каждую колонку ReAllocMem(P, theBitmap.Height*SizeOf(TRGBTriple)); for Col:= 0 to theBitmap.Width - 1 do begin //- считываем первую колонку в TRow: for Row:= 0 to theBitmap.Height - 1 do ACol[Row]:= theRows[Row][Col]; BlurRow(Slice(ACol^, theBitmap.Height), K, P); //теперь помещаем обработанный столбец на свое место в данные изображения: for Row:= 0 to theBitmap.Height - 1 do theRows[Row][Col]:= ACol[Row]; end; FreeMem(theRows); FreeMem(ACol); ReAllocMem(P, 0); end; end.

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

procedure TForm1.Button1Click(Sender: TObject); var b: TBitmap; begin if not openDialog1.Execute then exit; b:= TBitmap.Create; b.LoadFromFile(OpenDialog1.Filename); b.PixelFormat:= pf24Bit; Canvas.Draw(0, 0, b); GBlur(b, StrToFloat(Edit1.text)); Canvas.Draw(b.Width, 0, b); b.Free; end;

Имейте в виду, что 24-битные изображения при системной 256-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра. [000124]

Инструмент `Лассо`

Вот возможное решение... В обработчике события OnMouseDown для формы, где вы хотите использовать инструмент "Лассо":

bMarquee :=  True;     { установите логическое значение так, чтобы различать при каком событии мыши должна быть сделана операция } ptOrigin := Point( X, Y );   { получаем отправную точку для рисования инструмента } ptMove  := Point( X, Y );    { инициализируем конечную точку } здесь устанавливаем атрибуты кисти и карандаша (pen и brush), или вызываем общую процедуру, которая может быть использована модуле где-то еще. Pen.Color := clBlack; Pen.Width := 1; Pen.Style := psDash; Brush.Style := bsClear; затем рисуем прямоугольник инструмента DrawMarquee(ptOrigin, ptMove, pmNotXor );

В обработчике события формы OnMouseMove...

if bMarquee = True then begin DrawMarquee(ptOrigin, ptMove, pmNotXor ); DrawMarquee(ptOrigin, Point( X, Y ), pmNotXor ); ptMove := Point( X, Y ); Canvas.Pen.Mode := pmCopy; end;

В обработчике события формы OnMouseUp...

if bMarquee = True then begin bMarquee := False; DrawMarquee(ptOrigin, Point( X, Y ), pmNotXor ); ptMove := Point( X, Y ); { осуществляем проверку на любые пересечения между прямоугольником инструмента и элементами управления } - вызываем процедуру, которая выделит (передаст фокус) необходимым элементам управления end;

Процедура DrawMarquee...

procedure myForm.DrawMarquee( mStart, mStop : TPoint; AMode : TPenMode); begin Canvas.Pen.Mode := AMode; Canvas.Rectangle( mStart.X, mStart.Y, mStop.X, mStop.Y ); end;

[001940]

Использование иконки как глифа

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls; type TForm1 = class(TForm) BitBtn1: TBitBtn; Button1: TButton; Bevel1: TBevel; BitBtn2: TBitBtn; Label1: TLabel; Label2: TLabel; SpeedButton1: TSpeedButton; procedure BitBtn2Click(Sender: TObject); procedure Button1Click(Sender: TObject); private public end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.BitBtn2Click(Sender: TObject); begin close; {Закрываем приложение} end; procedure TForm1.Button1Click(Sender: TObject); var Image1 : TImage;  {Объявляем тип переменной} begin try  {Ловим ошибки, освобождаем память} Image1 := TImage.Create(Self); {Создаем временно} Image1.Picture.LoadFromFile('\Delphi\Images\Icons\Earth.ico'); {Загружаем файл} with BitBtn1.Glyph do  {Сначала работаем с BitBtn} begin Width := 32;  {Высота и ширина стандартной иконки} Height := 32; Canvas.Brush.Color := clBtnFace; {Проверяем цвет кнопки} Canvas.Rectangle(0,0,32,32); {Объявляем область изображения} Canvas.Draw(0,0,Image1.Picture.Icon); {Рисуем область изображения} end; with SpeedButton1.Glyph do  {Теперь делаем то же самое для SpeedButton} begin Width := 32; Height := 32; Canvas.Brush.Color := clBtnFace; Canvas.Rectangle(0,0,32,32); Canvas.Draw(0,0,Application.Icon); {Берем иконку вашего приложения} end; finally {Завершение Try-блока} Image1.Free; {Освобождаем временное изображение, которое мы создали для BitBtn1} Button1.Enabled := False; {Убедимся в том, что процесс запущен однажды} end; {Завершение проверки на ошибки} end;   {Завершение процедуры Button1} end.

[001950]

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

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

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

Взамен я предлагаю использовать функции DIB API. Вот некоторый код, позволяющий вам изменять таблицу цветов. Просто напишите метод с такими же параметрами, как у TFiddleProc и и изменяйте ColorTable, передаваемое как параметр. Затем просто вызовите процедуру FiddleBitmap, передающую TBitmap и ваш fiddle-метод, например так:

FiddleBitmap( MyBitmap, Fiddler ) ;

type TFiddleProc = procedure( var ColorTable : TColorTable ) of object ; const LogPaletteSize = sizeof( TLogPalette ) + sizeof( TPaletteEntry ) * 255 ; function  PaletteFromDIB( BitmapInfo : PBitmapInfo ) : HPalette ; var LogPalette : PLogPalette ; i              : integer ; Temp           : byte ; begin with BitmapInfo^, bmiHeader do begin GetMem( LogPalette, LogPaletteSize ) ; try with LogPalette^ do begin palVersion := $300 ; palNumEntries := 256 ; Move( bmiColors, palPalEntry, sizeof( TRGBQuad ) * 256 ) ; for i := 0 to 255 do with palPalEntry[ i ] do begin Temp := peBlue ; peBlue := peRed ; peRed := Temp ; peFlags := PC_NOCOLLAPSE ; end ; { создаем палитру } Result := CreatePalette( LogPalette^ ) ; end ; finally FreeMem( LogPalette, LogPaletteSize ) ; end ; end ; end ; { Следующая процедура на основе изображения создает DIB, изменяет ее таблицу цветов, создавая тем самым новую палитру, после чего передает ее обратно изображению. При этом используется метод косвенного вызова, с помощью которого изменяется палитра цветов - ей передается array[ 0..255 ] of TRGBQuad. } procedure FiddleBitmap( Bitmap : TBitmap ;  FiddleProc : TFiddleProc ) ; const BitmapInfoSize = sizeof( TBitmapInfo ) + sizeof( TRGBQuad ) * 255 ; var BitmapInfo : PBitmapInfo ; Pixels     : pointer ; InfoSize   : integer ; ADC        : HDC ; OldPalette : HPalette ; begin { получаем DIB } GetMem( BitmapInfo, BitmapInfoSize ) ; try { меняем таблицу цветов - ПРИМЕЧАНИЕ: она использует 256 цветов DIB } FillChar( BitmapInfo^, BitmapInfoSize, 0 ) ; with BitmapInfo^.bmiHeader do begin biSize := sizeof( TBitmapInfoHeader ) ; biWidth := Bitmap.Width ; biHeight := Bitmap.Height ; biPlanes := 1 ; biBitCount := 8 ; biCompression := BI_RGB ; biClrUsed := 256 ; biClrImportant := 256 ; GetDIBSizes( Bitmap.Handle, InfoSize, biSizeImage ) ; { распределяем место для пикселей } Pixels := GlobalAllocPtr( GMEM_MOVEABLE, biSizeImage ) ; try { получаем пиксели DIB } ADC := GetDC( 0 ) ; try OldPalette := SelectPalette( ADC, Bitmap.Palette, false ) ; try RealizePalette( ADC ) ; GetDIBits( ADC,Bitmap.Handle,0,biHeight,Pixels,BitmapInfo^, DIB_RGB_COLORS ) ; finally SelectPalette( ADC, OldPalette, true ) ; end ; finally ReleaseDC( 0, ADC ) ; end ; { теперь изменяем таблицу цветов } FiddleProc( PColorTable( @BitmapInfo^.bmiColors )^ ) ; { создаем палитру на основе новой таблицы цветов } Bitmap.Palette := PaletteFromDIB( BitmapInfo ) ; OldPalette := SelectPalette( Bitmap.Canvas.Handle, Bitmap.Palette,false ) ; try RealizePalette( Bitmap.Canvas.Handle ) ; StretchDIBits( Bitmap.Canvas.Handle, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight, Pixels, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY ) ; finally SelectPalette( Bitmap.Canvas.Handle, OldPalette, true ) ; end ; finally GlobalFreePtr( Pixels ) ; end ; end ; finally FreeMem( BitmapInfo, BitmapInfoSize ) ; end ; end ; { Пример "fiddle"-метода } procedure TForm1.Fiddler( var ColorTable : TColorTable ) ; var i : integer ; begin for i := 0 to 255 do with ColorTable[ i ] do begin rgbRed := rgbRed * 9 div 10 ; rgbGreen := rgbGreen * 9 div 10 ; rgbBlue := rgbBlue * 9 div 10 ; end ; end ;

- Mike Scott [000827]

Как бороться с "квадратичностью" Image

Аркадия советует:

При вставке какой-либо картинки в Image с произвольными очертаниями, можно легко обратиться к самой картинке а не к ненужному "куску" Image.

Решение:

Вставляем картинку ,например с белым фоном, transpert:=true и на OnMouseOver, или еще где, пишем:

if image1.picture.bitmep.canvas.pixels[X, Y]<>clwhite then image1.cursor:=crHourGlass else image1.cursor:=crDefault

Пояснение: при наведении прога проверяет цвет пиксела под указатем и если оно отличается от белого, т.е. цвета фона, то указатель меняет свой вид! [001702]

Как быстро нарисовать тень в заданном регионе?

Nomadic советует:

procedure TForm2.DrawShadows(WDepth, HDepth : Integer); var Dst, RgnBox : TRect; hOldDC : HDC; OffScreen : TBitmap; Pattern : TBitmap; Bits : array[0..7] of WORD; begin Bits[0] := $0055; Bits[1] := $00aa; Bits[2] := $0055; Bits[3] := $00aa; Bits[4] := $0055; Bits[5] := $00aa; Bits[6] := $0055; Bits[7] := $00aa; hOldDC := Canvas.Handle; Canvas.Handle := GetWindowDC(Form1.Handle); OffsetRgn(ShadeRgn, WDepth, HDepth); GetRgnBox(ShadeRgn, RgnBox); Pattern := TBitmap.Create; Pattern.ReleaseHandle; Pattern.Handle := CreateBitmap(8, 8, 1, 1, @(Bits[0])); Canvas.Brush.Bitmap := Pattern; OffScreen := TBitmap.Create; OffScreen.Width := RgnBox.Right-RgnBox.Left; OffScreen.Height := RgnBox.Bottom-RgnBox.Top; Dst := Rect(0, 0, OffScreen.Width, OffScreen.Height); OffsetRgn(ShadeRgn, 0, -RgnBox.Top); FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); OffsetRgn(ShadeRgn, 0, RgnBox.Top); // BitBlt работает быстрее CopyRect BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height, Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND); Canvas.Brush.Color := clBlack; FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width, OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT); OffScreen.Free; Pattern.Free; OffsetRgn(ShadeRgn, -WDepth, -HDepth); ReleaseDC(Form1.Handle, Canvas.Handle); Canvas.Handle := hOldDC; end;

Комментарии :
Функция рисует тень сложной формы на форме Form2 (извиняюсь за стиль). Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API. [001177]

Как быстро очистить канву?

InValidateRect(Canvas.handle,NIL,True);

Если вы используете холст формы, то попробуйте следующее:

InValidateRect(form1.handle,NIL,True);

(или взамен передать дескриптор компонента)

Это очистит хост:

canvas.fillrect(canvas.cliprect) ;

[001811]

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

Nomadic советует:

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

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

[001651]

Как извлечь доли составляющих цветов из данного цвета?

Своим опытом делится Олег Кулабухов:

Используйте GetRValue(), GetGValue(), и GetBValue().

procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Pen.Color := clRed; Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Blue := ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color))); end;

[001892]

Как мне из Handle битовой картинки, получить адрес битового изображения в памяти?

Nomadic советует:

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

Сразу оговорюсь, что все это работает только под Win95/NT.

type TarrRGBTriple=array[byte] of TRGBTriple; ParrRGBTriple=^TarrRGBTriple; {организует битмэп размером SX,SY;true_color} procedure TMBitmap.Allocate(SX,SY:integer); var DC:HDC; begin if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был} BM:=0; PB:=nil; fillchar(BI,sizeof(BI),0); with BI.bmiHeader do {заполняем структуру с параметрами битмэпа} begin biSize:=sizeof(BI.bmiHeader); biWidth:=SX; biHeight:=SY; biPlanes:=1; biBitCount:=24; biCompression:=BI_RGB; biSizeImage:=0; biXPelsPerMeter:=0; biYPelsPerMeter:=0; biClrUsed:=0; biClrImportant:=0; FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)} if (biWidth or biHeight)<>0 then begin DC:=CreateDC('DISPLAY',nil,nil,nil); {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле, что позволяет ускорять работу и экономить память при генерировании большого битмэпа} {!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0); DeleteDC(DC); {в PB получаем указатель на битмэп-----^^} if BM=0 then Error('error creating DIB'); end; end; end; {эта процедура загружает из файла true-color'ный битмэп} procedure TMBitmap.LoadFromFile(const FileName:string); var HF:integer; {file handle} HM:THandle; {file-mapping handle} PF:pchar; {pointer to file view in memory} i,j: integer; Ofs:integer; begin {открываем файл} HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite); if HF<0 then Error('open file '''+FileName+''''); try {создаем объект-проецируемый файл} HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil); if HM=0 then Error('can''t create file mapping'); try {собственно проецируем объект в адресное } PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0); {получаем указатель на область памяти, в которую спроецирован файл} if PF=nil then Error('can''t create map view of file'); try {работаем с файлом как с областью памяти через указатель PF} if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format'); Ofs:=PBitmapFileHeader(PF)^.bfOffBits; with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do begin if (biSize<>40) or (biPlanes<>1) then Error('file format'); if (biCompression<>BI_RGB) or (biBitCount<>24) then Error('only true-color BMP supported'); {выделяем память под битмэп} Allocate(biWidth,biHeight); end; for j:=0 to BI.bmiHeader.biHeight-1 do for i:=0 to BI.bmiHeader.biWidth-1 do {Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе} Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i]; finally UnmapViewOfFile(PF); end; finally CloseHandle(HM); end; finally FileClose(HF); end; end; {эта функция - реализация Pixels read} function TMBitmap.GetPixel(X,Y:integer):PRGB; begin if (X>=0) and (X<BI.bmiHeader.biWidth) and (Y>=0) and (Y<BI.bmiHeader.biHeight) then Result:=PRGB(PB+(Y)*FLineSize+X*3) else Result:=PRGB(PB); end;

Если у вас на форме есть компонент TImage, то можно сделать так:

var BMP:TMBitmap; B:TBitmap; ... BMP.LoadFromFile(..); B:=TBitmap.Create; B.Handle:=BMP.Handle; Image1.Picture.Bitmap:=B;

и загруженный битмэп появится на экране. [001204]

Как мне немного ускорить вывод моей графики?

Попробуем воспользоваться только методами VCL; надеюсь это сможет вам помочь. BitBlt позволяет использовать CopyRect.

var BitMap : TBitmap; procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.Width := 400; Bitmap.Height := 400; PaintBox1.Width := 200; PaintBox1.Height := 200; With Bitmap.Canvas do begin Pen.Color := clNavy; Ellipse(0,0,399,399); end; end; procedure TForm1.FormDestroy(Sender: TObject); begin Bitmap.Free; end; procedure TForm1.Button1Click(Sender: TObject); var Limit : Word; I : Word; PBBottom, PBRight : Word; begin PBBottom := PaintBox1.Height - 1; PBRight := PaintBox1.Width - 1; Limit := Bitmap.Width - PaintBox1.Width; For I := 0 to Limit do PaintBox1.Canvas.CopyRect(Rect(0,0,PBRight,PBBottom), Bitmap.Canvas, Rect(I,0,I+PBRight,PBBottom)); end;

[001935]

Как можно узнать количество цветов текущего режима?

Своим опытом делится Олег Кулабухов: GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) * GetDeviceCaps(Form1.Canvas.Handle, PLANES) Для получения общего количества битов, используемых для получения цвета используются следующие значения. 1 = 2 colors bpp 4 = 16 colors bpp 8 = 256 colors bpp 15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp 16 = 65535 colors bpp 24 = 16,777,216 colors bpp 32 = 16,777,216 colors (то же, что и 24) bpp Вы можете использовать: NumberOfColors := (1 shl (GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) * GetDeviceCaps(Form1.Canvas.Handle, PLANES)); для подсчета общего количества используемых цветов. [001775]

Как нарисовать линию?

Своим опытом делится Олег Кулабухов:

Рисуем линию от 10,10 до 100,100 и окружность радиусом 10:

procedure DDAProc(x : integer; y : integer; LParam : LongInt) {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin if x mod 10 = 0 then TCanvas(LParam).Ellipse(x - 10, y - 10, x + 10, y + 10); end; procedure TForm1.Button1Click(Sender: TObject); begin LineDDA(10, 10, 100, 100, @DDAProc, {$IFDEF WIN32} LongInt(Form1.Canvas) {$ELSE} Form1.Canvas {$ENDIF} ); end;

[001914]

Как перевести цвет в соответствующий цвет тени?

Своим опытом делится Олег Кулабухов:

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

function RgbToGray(RGBColor : TColor) : TColor; var Gray : byte; begin Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor ))); Result := RGB(Gray, Gray, Gray); end; procedure TForm1.FormCreate(Sender: TObject); begin Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); end;

[001890]

Как поменять цвет фона текста?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject); var OldTextColor : TColorRef; OldBkColor : TColorRef; OldBkMode : Integer; begin OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255)); OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0)); OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE); TextOut(Form1.Canvas.Handle, 100, 100, 'Blue text on red Background', 27); SetBkMode(Form1.Canvas.Handle, OldBkMode); SetBkColor(Form1.Canvas.Handle, OldBkColor); SetTextColor(Form1.Canvas.Handle, OldTextColor); end;

[001818]

Как поместить прозрачный текст на 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;

[001810]

Как рисовать на органе управления, например, на TPanel?

Nomadic советует:

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.

{ Example. We recommend You to create this component through Component Wizard. In Delphi 1 it can be found as 'File|New Component...', and can be found as 'Component|New Component...' in Delphi 2 or above. } type TcPanel = class(TPanel) public property Canvas; end;

У меня есть маленькое замечание.

Если у объекта нет свойства Canvas (у TDBEdit вpоде-бы нет), то, по кpайней меpе в D3, можно использовать класс TControlCanvas. Пpимеpное использование:

var cc: TControlCanvas; ... cc := TControlCanvas.Create; cc.Control := yourControl; ...

и далее как обычно можно использовать методы Canvas. [001185]

Как рисовать прямо на экране?

Nomadic приводит следующий код:

........................................................ Procedure DrawOnScreen; Var DC:HDC; DesktopCanvas:TCanvas; begin DC:=GetDC(0);   // получили DC экрана try DesktopCanvas:=TCanvas.Create; DesktopCanvas.Handle:=DC; .................. // здесь рисуем на Canvas экрана .................. finally ReleaseDC(0,DC); DesktopCanvas.Free; end; end; ........................................................

[001646]

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

Nomadic советует:

Надо обpабатывать сообщение CM_HITTEST (Это сообщение получают даже потомки от TGraphicsControl, не имеющего своего HWND).

Hапpимеp, так:

procedure TLine.CMHitTest(var Message: TWMNCHitTest); begin if PointInLineReg(Message.XPos, Message.YPos) then begin Message.Result := 1; end else begin Message.Result := 0; end; end;

Для органов управления Windows, если Вы не используете VCL, требуется обрабатывать сообщение WM_NCHITTEST. [001172]

Как скопировать экран (или его часть) в TBitmap?

Nomadic советует:

Например, с помощью WinAPI так -

var bmp: TBitmap; DC: HDC; begin bmp:=TBitmap.Create; bmp.Height:=Screen.Height; bmp.Width:=Screen.Width; DC:=GetDC(0);  //Дескpиптоp экpана bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DC, 0, 0, SRCCOPY); bmp.SaveToFile('Screen.bmp'); ReleaseDC(0, DC); end;

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры

Var Desktop :TCanvas ; BitMap  :TBitMap; begin DesktopCanvas:=TCanvas.Create; DesktopCanvas.Handle:=GetDC(Hwnd_Desktop); BitMap := TBitMap.Create; BitMap.Width := Screen.Width; BitMap.Height:=Screen.Height; Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect, DesktopCanvas, DesktopCanvas.ClipRect); ........ end;

[001618]

---

---