Виртуальная библиотека Delphi

// знаю, удаляются ли ненужные палитры автоматически

if Palette=0 then exit; //Палитра отсутствует

PaletteSize := 0;

if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;

// Количество элементов в палитре = paletteSize

if PaletteSize = 0 then Exit; // палитра пустая

// определение размера палитры

LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);

GetMem(LogPalette, LogSize);

try

// заполнение полей логической палитры

with LogPalette^ do begin

palVersion := $0300; palNumEntries := PaletteSize;

GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);

// делаете что нужно с палитрой, например:

Red := palPalEntry[PaletteSize-1].peRed;

Edit1.Text := 'Красная составляющего последнего элемента палитры ='+IntToStr(Red);

palPalEntry[PaletteSize-1].peRed := 0;

//.......................................

end;

// завершение работы

Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);

finally

FreeMem(LogPalette, LogSize);

// я должен позаботиться сам об удалении Released Palette

DeleteObject(Palette);

end;

end;

{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)

и меняет его палитру при нажатии кнопки }

unit bmpformu;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type TBmpForm = class(TForm)

Button1: TButton;

procedure FormDestroy(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

Bitmap: TBitmap;

procedure ScrambleBitmap;

procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;

end;

var

BmpForm: TBmpForm;

implementation

{$R *.DFM}

procedure TBmpForm.FormCreate(Sender: TObject);

begin

Bitmap := TBitmap.Create;

Bitmap.LoadFromFile('bor6.bmp');

end;

procedure TBmpForm.FormDestroy(Sender: TObject);

begin

Bitmap.Free;

end;

// since we're going to be painting the whole form, handling this

// message will suppress the uneccessary repainting of the background

// which can result in flicker.

procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);

begin

m.Result := LRESULT(False);

end;

procedure TBmpForm.FormPaint(Sender: TObject);

var x, y: Integer;

begin

y := 0;

while y < Height do begin

x := 0;

while x < Width do begin

Canvas.Draw(x, y, Bitmap);

x := x + Bitmap.Width;

end;

y := y + Bitmap.Height;

end;

end;

procedure TBmpForm.Button1Click(Sender: TObject);

begin

ScrambleBitmap; Invalidate;

end;

// scrambling the bitmap is easy when it's has 256 colors:

// we just need to change each of the color in the palette

// to some other value.

procedure TBmpForm.ScrambleBitmap;

var

pal: PLogPalette;

hpal: HPALETTE;

i: Integer;

begin

pal := nil;

try

GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);

pal.palVersion := $300;

pal.palNumEntries := 256;

for i := 0 to 255 do begin

pal.palPalEntry[i].peRed := Random(255);

pal.palPalEntry[i].peGreen := Random(255);

pal.palPalEntry[i].peBlue := Random(255);

end;

hpal := CreatePalette(pal^);

if hpal <> 0 then Bitmap.Palette := hpal;

finally

FreeMem(pal);

end;

end;

end.

Function PaintDesktop(HDC) : boolean;

Например:

PaintDesktop(form1.Canvas.Handle);

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.

Пример:

Рисуются изображения размером 32×16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!

Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}

procedure TForm1.bLoadClick(Sender: TObject);

VAR S : String;

begin

ListBox1.Clear; {чистим список}

S := '*.bmp'#0; {задаем шаблон}

ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}

end;

............

{Отобразить изображения и имена файлов в ListBox}

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: DrawState);

VAR

Bitmap : TBitmap;

Offset : Integer;

BMPRect: TRect;

begin

WITH (Control AS TListBox).Canvas DO BEGIN

FillRect(Rect);

Bitmap := TBitmap.Create;

Bitmap.LoadFromFile(ListBox1.Items[Index]);

Offset := 0;

IF Bitmap <> NIL THEN BEGIN

BMPRect := Bounds(Rect.Left+2, Rect.Top+2,