Как создать цветовую паллитру

Below are functions that help to create a palette (an identity palette, BTW) from an array of RGBQuads (such as you would find in the palette section of a .BMP file). I stole this from the WinG documentation, and converted it to Delphi. First call ClearSystemPalette, then you can get an identity palette by calling CreateIdentityPalette. If you plan to try palette animation, work in a 256-color mode, and change all the PC_NOCOLLAPSE entries below to PC_RESERVED. Besides creating the palette, the other pieces to the puzzle are:

1. Override the form's GetPalette method, so that it returns the new palette.

2. Select and realize the new palette just before you paint.
OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
{ Do your painting here }
SelectPalette(Canvas.Handle, OldPal, False);

3. Remember to release the palette when you are done using DeleteObject

4. If you are used using the RGB function to get color values, use the PaletteRGB function in its place.

function CreateIdentityPalette(const aRGB; nColors: Integer): HPALETTE;

type

 QA = array[0..255] of TRGBQUAD;

var

 Palette: PLOGPALETTE;

 PalSize: Word;

 ScreenDC: HDC;

 I: Integer;

 nStaticColors: Integer;

 nUsableColors: Integer;

begin

 PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;

 GetMem(Palette, PalSize);

 try

  with Palette^ do

  begin

  palVersion := $0300;

  palNumEntries := 256;

  ScreenDC := GetDC(0);

  try

  { For SYSPAL_NOSTATIC, just copy the color table into a PALETTEENTRY

  array and replace the first and last entries with black and white }


  if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC) then

  begin

  { Fill in the palette with the given values, marking each with PalFlag }

{$R-}

  for i := 0 to (nColors - 1) do

  with palPalEntry[i], QA(aRGB)[I] do

  begin

  peRed := rgbRed;

  peGreen := rgbGreen;

  peBlue := rgbBlue;

  peFlags := PC_NOCOLLAPSE;

  end;

  { Mark any unused entries with PalFlag }

  for i := nColors to 255 do

  palPalEntry[i].peFlags := PC_NOCOLLAPSE;

  { Make sure the last entry is white -- This may replace an entry in the array!}

  I := 255;

  with palPalEntry[i] do

  begin

  peRed := 255;

  peGreen := 255;

  peBlue := 255;

  peFlags := 0;

  end;

  { And the first is black -- This may replace an entry in the array!}

  with palPalEntry[0] do

  begin

  peRed := 0;

  peGreen := 0;

  peBlue := 0;

  peFlags := 0;

  end;

{$R+}

  end

  else

  begin

  { For SYSPAL_STATIC, get the twenty static colors into the

  array, then fill in the empty spaces with the given color table }


  { Get the static colors from the system palette }

  nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);

  GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);

{$R-}

  { Set the peFlags of the lower static colors to zero }

  nStaticColors := nStaticColors shr 1;

  for i := 0 to (nStaticColors - 1) do

  palPalEntry[i].peFlags := 0;

  { Fill in the entries from the given color table}

  nUsableColors := nColors - nStaticColors;

  for I := nStaticColors to (nUsableColors - 1) do

  with palPalEntry[i], QA(aRGB)[i] do

  begin

  peRed := rgbRed;

  peGreen := rgbGreen;

  peBlue := rgbBlue;

  peFlags := PC_NOCOLLAPSE;

  end;

  { Mark any empty entries as PC_NOCOLLAPSE }

  for i := nUsableColors to (255 - nStaticColors) do

  palPalEntry[i].peFlags := PC_NOCOLLAPSE;

  { Set the peFlags of the upper static colors to zero }

  for i := (256 - nStaticColors) to 255 do

  palPalEntry[i].peFlags := 0;

  end;

  finally

  ReleaseDC(0, ScreenDC);

  end;

  end;

  { Return the palette }

  Result := CreatePalette(Palette^);

 finally

  FreeMem(Palette, PalSize);

 end;

end;

procedure ClearSystemPalette;

var

 Palette: PLOGPALETTE;

 PalSize: Word;

 ScreenDC: HDC;

 I: Word;

const

 ScreenPal: HPALETTE = 0;

begin

 PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255; {256th = [0] }

 GetMem(Palette, PalSize);

 try

  FillChar(Palette^, PalSize, 0);

  Palette^.palVersion := $0300;

  Palette^.palNumEntries := 256;

{$R-}

  for I := 0 to 255 do

  with Palette^.palPalEntry[I] do

  peFlags := PC_NOCOLLAPSE;

{$R+}

  { Create, select, realize, deselect, and delete the palette }

  ScreenDC := GetDC(0);

  try

  ScreenPal := CreatePalette(Palette^);

  if ScreenPal <> 0 then

  begin

  ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);

  RealizePalette(ScreenDC);

  ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);

  DeleteObject(ScreenPal);

  end;

  finally

  ReleaseDC(0, ScreenDC);

  end;

 finally

  FreeMem(Palette, PalSize);

 end;

end;

unit VideoFcns;
interface
uses Windows;
procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer = -1);
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
implementation
procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
 j: integer;
 cp: PRGBQUAD;
begin
 if threshold <> -1 then
 begin
  BinaryColorTable(clrtable, threshold);
  exit;
 end;
 cp := clrtable;
 for j := 0 to 255 do
 begin
  {here you can set rgb components the way you like}
  cp^.rgbBlue := j;
  cp^.rgbGreen := j;
  cp^.rgbRed := j;
  cp^.rgbReserved := 0;
  inc(cp);
 end;
end;
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
 j: integer;
 g: integer;
 cp: PRGBQUAD;
begin
 cp := clrtable;
 for j := 0 to 255 do
 begin
  if j < threshold then
  g := 0
  else
  g := 255;
  cp^.rgbBlue := g;
  cp^.rgbGreen := g;
  cp^.rgbRed := g;
  cp^.rgbReserved := 0;
  inc(cp);
 end;
end;

Here is an example how palette is used:

procedure TBmpByteImage.FillBMPInfo(BMPInfo: pointer; const Wi, He: integer);

var

 p: ^TBitmapInfo;

begin

 p := BMPInfo;

 p^.bmiHeader.biSize := sizeof(p.bmiHeader);

 if Wi <> 0 then

  p^.bmiHeader.biWidth := Wi

 else

  p^.bmiHeader.biWidth := w;

 if He <> 0 then

  p^.bmiHeader.biHeight := He

 else

  p^.bmiHeader.biHeight := h;

 p^.bmiHeader.biPlanes := 1;

 p^.bmiHeader.biBitCount := 8;

 p^.bmiHeader.biCompression := BI_RGB;

 p^.bmiHeader.biClrUsed := 0;

 p^.bmiHeader.biClrImportant := 0;

end;

function TBmpByteImage.CreateDIB(const threshold: integer): HBITMAP;

var

 dc: HDC;

 bmpInfo: ^TBitmapInfo;

 BMPData: pointer;

 hBmp: HBITMAP;

 x, y: integer;

 cp1, cp2: pbyte;

begin

 GetMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);

 FillBMPInfo(BMPInfo);

 {I am using a grey palette}

 GrayColorTable(@bmpInfo^.bmiColors[0], threshold);

 dc := CreateDC('DISPLAY', nil, nil, nil);

 hBmp := CreateDIBSection(dc, bmpInfo^, DIB_RGB_COLORS, BMPData, 0, 0);

 DeleteDC(dc);

 FreeMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);

 cp2 := BMPData;

 for y := h - 1 downto 0 do

 begin

  cp1 := @g^[y]^[0];

  for x := 0 to w - 1 do

  begin

  cp2^ := cp1^;

  inc(cp1);

  inc(cp2);

  end;

 end;

 CreateDIB := hBmp;

end;

{and finally draw bitmap }

procedure TBmpByteImage.Draw(const where: TImage; const threshold: integer);

var

 hBmp: HBITMAP;

 Bitmap1: TBitmap;

begin

 hBmp := CreateDIB(threshold);

 if hBmp = 0 then

  exit;

 Bitmap1 := TBitmap.Create;

 with Bitmap1 do

 begin

  Handle := hBmp;

  Width := w;

  Height := h;

 end;

 where.picture.Bitmap := Bitmap1;

 Bitmap1.Free;

 GlobalFree(hBmp);

end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/

var
 Form1: TForm1;
 blueVal: Byte;
 BluePalette: HPalette;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
 LogicalPalette: PLogPalette;
 ColorIndex: LongInt;
begin
 GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
 GetSystemPaletteEntries(Canvas.Handle, 0, 256,
  LogicalPalette^.palPalEntry[0]);
 with LogicalPalette^ do
 begin
  palVersion := $300;
  palNumEntries := 256;
{$R-}
  for ColorIndex := 10 to 245 do
  with palPalEntry[ColorIndex] do
  begin
  peRed := 0;
  peGreen := 0;
  peBlue := 255 - (ColorIndex - 10);
  peFlags := PC_NOCOLLAPSE;
  end;
 end;
{$R+}
 BluePalette := CreatePalette(LogicalPalette^);
 FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
 DeleteObject(BluePalette);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
var
 OldPal: HPALETTE;
begin
 OldPal := SelectPalette(Canvas.Handle, BluePalette, False);
 RealizePalette(Canvas.Handle);
 canvas.pen.color := $02000000 or (BlueVal * $00010000);
 canvas.pen.width := 10;
 canvas.moveto(0, 0);
 canvas.lineto(X, Y);
 SelectPalette(Canvas.Handle, OldPal, False);
 Inc(BlueVal);
 if BlueVal > 255 then
  BlueVal := 0;
end;


Взято с http://delphiworld.narod.ru

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...