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

Previous  Top  Next

    
 

 

 

 

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.

 

Code:

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;

 

 

©Drkb::03698

 


Code:

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:

 

Code:

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;

 

©Drkb::03699

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

 

 

 


Code:

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;

 

©Drkb::03700

 

       

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