home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l040 / 11.ddi / WDOCDEMO.ZIP / PALTEST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  3.8 KB  |  129 lines
  1. {************************************************}
  2. {                                                }
  3. {   ObjectWindows Demo                           }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. program PaletteTest;
  9.  
  10. {$R-}
  11.  
  12. uses WinTypes, WinProcs, OWindows;
  13.  
  14. const
  15.   NumColors = 8;
  16.   RedVals : array[0..NumColors - 1] of Byte =
  17.     (0, 0, 0, 0, $FF, $FF, $FF, $FF);
  18.   GreenVals : array[0..NumColors - 1] of Byte =
  19.     (0, 0, $FF, $FF, 0, 0, $FF, $FF);
  20.   BlueVals : array[0..NumColors - 1] of Byte =
  21.     (0, $FF, 0, $FF, 0, $FF, 0, $FF);
  22.  
  23. type 
  24.   PaletteApplication = object(TApplication)
  25.     procedure InitMainWindow; virtual;
  26.   end;
  27.  
  28.   PTestWindow = ^TestWindow;
  29.   TestWindow = object(TWindow)
  30.     MyLogPalette: PLogPalette;
  31.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  32.     destructor Done; virtual;
  33.     procedure WMLButtonDown(var Msg: TMessage);
  34.       virtual wm_First + wm_LButtonDown;
  35.     procedure WMRButtonDown(var Msg: TMessage);
  36.       virtual wm_First + wm_RButtonDown;
  37.   end;
  38.  
  39. {  Helpful function for dealing with palette-index TColorRefs }
  40.        
  41. function PaletteIndex(W: Word): TColorRef;
  42. begin
  43.   PaletteIndex := $01000000 or W;
  44. end;
  45.    
  46. {--------------------------------------------------}
  47. { TestWindow method implementations:               }
  48. {--------------------------------------------------}
  49.  
  50. constructor TestWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  51. var
  52.   i: Integer;
  53. begin
  54.   inherited Init(AParent, ATitle);
  55.   GetMem(MyLogPalette, SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * NumColors);
  56.   MyLogPalette^.palVersion := $300;
  57.   MyLogPalette^.palNumEntries := NumColors;
  58.   for i := 0 to NumColors - 1 do
  59.   begin
  60.     MyLogPalette^.palPalEntry[i].peRed := RedVals[i];
  61.     MyLogPalette^.palPalEntry[i].peGreen := GreenVals[i];
  62.     MyLogPalette^.palPalEntry[i].peBlue := BlueVals[i];
  63.     MyLogPalette^.palPalEntry[i].peFlags := pc_Reserved;
  64.   end;
  65. end;
  66.  
  67. destructor TestWindow.Done;
  68. begin
  69.   FreeMem(MyLogPalette, (sizeof(TLogPalette) + sizeof(TPaletteEntry) * NumColors ));
  70.   inherited Done;
  71. end;
  72.  
  73. procedure TestWindow.WMLButtonDown(var Msg: TMessage);
  74. var
  75.   i: Integer;
  76.   ABrush, OldBrush: HBrush;
  77.   OldPalette: HPalette;
  78.   ThePalette: HPalette;
  79.   TheDC: HDC;
  80. begin
  81.   ThePalette := CreatePalette(MyLogPalette^);
  82.   TheDC := GetDC(HWindow);
  83.   OldPalette := SelectPalette(TheDC, ThePalette, False);
  84.   RealizePalette(TheDC);
  85.   for i := 0 to NumColors - 1 do
  86.   begin
  87.     ABrush := CreateSolidBrush(PaletteIndex(i));
  88.     OldBrush := SelectObject(TheDC, ABrush);
  89.     Rectangle(TheDC, i * 25, i * 25, i * 25 + 20, i * 25 + 20);
  90.     SelectObject(TheDC, OldBrush);
  91.     DeleteObject(ABrush);
  92.   end;
  93.   SelectPalette(TheDC, OldPalette, False);
  94.   ReleaseDC(HWindow, TheDC);
  95.   DeleteObject(ThePalette);
  96. end;
  97.  
  98. procedure TestWindow.WMRButtonDown(var Msg: TMessage);
  99. var
  100.   i: Integer;
  101.   APaletteEntry : TPaletteEntry;
  102. begin
  103.   APaletteEntry := MyLogPalette^.palPalEntry[0];
  104.   for i := 0 to NumColors - 2 do
  105.     MyLogPalette^.palPalEntry[i] := MyLogPalette^.palPalEntry[i + 1] ;
  106.   i := NumColors - 1;
  107.   MyLogPalette^.palPalEntry[i] := APaletteEntry;
  108. end;
  109.  
  110. {--------------------------------------------------}
  111. { PaletteApplication method implementations:       }
  112. {--------------------------------------------------}
  113.  
  114. procedure PaletteApplication.InitMainWindow;
  115. begin
  116.   MainWindow := New(PTestWindow, Init(nil, 'Test Palettes'));
  117. end;
  118.  
  119. {--------------------------------------------------}
  120. { Main program:                                    }
  121. {--------------------------------------------------}
  122. var
  123.    PalApp: PaletteApplication;
  124. begin
  125.   PalApp.Init('PaletteApp');
  126.   PalApp.Run;
  127.   PalApp.Done;
  128. end.
  129.