home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programming Unleashed / Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso / misc / colpal / colpal.dpr next >
Encoding:
Text File  |  1995-03-21  |  2.8 KB  |  129 lines
  1. program ColPal;
  2.  
  3. { Copyright (c) 1995 by Charlie Calvert }
  4.  
  5. { Playing with Windows Color Palettes }
  6.  
  7. uses
  8.   WinProcs,
  9.   WinTypes,
  10.   WinCrt;
  11.  
  12. const
  13.   TotalEntries = 256;
  14.  
  15. var
  16.   DC: HDC;
  17.   hWindow: HWnd;
  18.   Pals: array[1..TotalEntries] of TPaletteEntry;
  19.  
  20. procedure DrawOne(x, y: Integer; Color: LongInt);
  21. const
  22.   SizeX = 25;
  23.   SizeY = 25;
  24. var
  25.   i, j: Integer;
  26.   Col, Row: Integer;
  27.   MaxX, MaxY: Integer;
  28. begin
  29.   Col := x * Sizex;
  30.   Row := y * Sizey;
  31.   Rectangle(DC, Col, Row, Col + SizeX, Row + SizeY);
  32. end;
  33.  
  34. function GetColors(i: Integer): TColorRef;
  35. var
  36.   Color: TColorRef;
  37.   R, G, B: Integer;
  38. begin
  39.   Color := RGB(0, 0, i);
  40.   GetColors := Color;
  41. end;
  42.  
  43. procedure ShowColors;
  44. var
  45.   x, y, Color: Integer;
  46.   NewColor: LongInt;
  47.   NewBrush, OldBrush: HBrush;
  48.   RGBColor: TColorRef;
  49.   R: LongInt;
  50. begin
  51.   x := 0;
  52.   y := 1;
  53.   for Color := 1 to TotalEntries - 4 do begin
  54.     Inc(X);
  55.     if X > 14 then begin
  56.       X := 1;
  57.       Inc(y);
  58.     end;
  59.     R := GetColors(Color);
  60.     RGBColor := PaletteRGB(Lo(LoWord(R)), Hi(LoWord(R)), Lo(HiWord(R)));
  61.     NewBrush := CreateSolidBrush(RGBColor);
  62.     OldBrush := SelectObject(DC, NewBrush);
  63.     DrawOne(x, y, NewColor);
  64.     SelectObject(DC, OldBrush);
  65.     DeleteObject(NewBrush);
  66.   end;
  67. end;
  68.  
  69. procedure WriteFile;
  70. var
  71.   F: Text;
  72.   i: Integer;
  73. begin
  74.   Assign(F, 'ColPal.Txt');
  75.   ReWrite(F);
  76.   for i := 1 to TotalEntries do begin
  77.     WriteLn(F, Pals[i].peRed, ' ', Pals[i].peGreen, ' ', Pals[i].peBlue);
  78.     WriteLn('Writing file: ', i, ' of ', TotalEntries);
  79.   end;
  80.   Close(F);
  81. end;
  82.  
  83. function CreateNewPalette(Red, Green, Blue: Boolean): HPalette;
  84. var
  85.   Palette: HPalette;
  86.   i, Size: Integer;
  87.   R: TColorRef;
  88.   APal: PLogPalette;
  89. begin
  90.   Size := SizeOf(TLogPalette) * SizeOf(TPaletteEntry) + (TotalEntries - 1);
  91.   GetMem(APal, Size);
  92.   APal^.PalVersion := $300;
  93.   APal^.PalNumEntries := TotalEntries;
  94.   {$R-}
  95.   for i := 1 to TotalEntries do begin
  96.     R := GetColors(i);
  97.     APal^.PalPalEntry[i].peRed := Lo(LoWord(R));
  98.     APal^.PalPalEntry[i].peGreen := Hi(LoWord(R));
  99.     APal^.PalPalEntry[i].peBlue := Lo(HiWord(R));
  100.     APal^.PalPalEntry[i].peFlags := 0;
  101.   end;
  102.   {$R+}
  103.   Palette := CreatePalette(APal^);
  104.   FreeMem(APal, Size);
  105.   CreatenewPalette := Palette;
  106. end;
  107.  
  108. var
  109.   OldPal, Palette: HPalette;
  110.   i: Integer;
  111. begin
  112.   Write('h');
  113.   hWindow := GetFocus;
  114.   ShowWindow(HWindow, Sw_ShowMaximized);
  115.   DC := GetDC(HWindow);
  116.   WriteLn('i');
  117.   for i := 1 to 1 do begin
  118.     GotoXY(1, 1); WriteLn(i, '                                 ');
  119.     Palette := CreateNewPalette(True, False, False);
  120.     OldPal := SelectPalette(DC, Palette, False);
  121.     RealizePalette(DC);
  122.     GetSystemPaletteEntries(DC, 10, TotalEntries - 10, Pals);
  123.     ShowColors;
  124.     SelectPalette(DC, OldPal, False);
  125.     DeleteObject(Palette);
  126.   end;
  127.   ReleaseDC(hWindow, DC);
  128. end.
  129.