home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 23 / IOPROG_23.ISO / SOFT / DELPHIX.ZIP / Samples / Graphic / PaletteAnimation / Unit1.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1998-10-06  |  3.6 KB  |  154 lines
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   DXClass, ExtCtrls, DXDraws, StdCtrls, DIB;
  8.  
  9. type
  10.   TForm1 = class(TDXForm)
  11.     DXDraw1: TDXDraw;
  12.     Button1: TButton;
  13.     Button2: TButton;
  14.     Button3: TButton;
  15.     Button4: TButton;
  16.     DXImageList1: TDXImageList;
  17.     procedure Button3Click(Sender: TObject);
  18.     procedure Button2Click(Sender: TObject);
  19.     procedure Button1Click(Sender: TObject);
  20.     procedure Button4Click(Sender: TObject);
  21.     procedure FormCreate(Sender: TObject);
  22.     procedure DXDraw1InitializeSurface(Sender: TObject);
  23.     procedure DXDraw1RestoreSurface(Sender: TObject);
  24.   private
  25.     procedure FadeIn(Time: Integer; Col: Integer);
  26.     procedure FadeOut(Time: Integer; Col: Integer);
  27.     procedure Flash(Time: Integer; Col: Integer);
  28.   end;
  29.  
  30. var
  31.   Form1: TForm1;
  32.  
  33. implementation
  34.  
  35. {$R *.DFM}
  36.  
  37. function ComposeColor(Dest, Src: TRGBQuad; Percent: Integer): TRGBQuad;
  38. begin
  39.   with Result do
  40.   begin
  41.     rgbRed := Src.rgbRed+((Dest.rgbRed-Src.rgbRed)*Percent div 256);
  42.     rgbGreen := Src.rgbGreen+((Dest.rgbGreen-Src.rgbGreen)*Percent div 256);
  43.     rgbBlue := Src.rgbBlue+((Dest.rgbBlue-Src.rgbBlue)*Percent div 256);
  44.     rgbReserved := 0;
  45.   end;
  46. end;
  47.  
  48. procedure TForm1.FadeOut(Time: Integer; Col: Integer);
  49. var
  50.   t: DWORD;
  51.   i, p, o: Integer;
  52. begin
  53.   if not DXDraw1.CanDraw then Exit;
  54.   if not DXDraw1.CanPaletteAnimation then Exit;
  55.  
  56.   {  Fade out  }
  57.   t := GetTickCount;
  58.   o := 0;
  59.   while Abs(GetTickCount-t)<Time do
  60.   begin
  61.     p := Min(Max(Abs(GetTickCount-t)*255 div Time, 0), 255);
  62.  
  63.     if p<>o then
  64.     begin
  65.       o := p;
  66.  
  67.       for i:=0 to 255 do
  68.         DXDraw1.ColorTable[i] := ComposeColor(RGBQuad(GetRValue(Col), GetGValue(Col), GetBValue(Col)),
  69.           DXDraw1.DefColorTable[i], p);
  70.  
  71.       DXDraw1.UpdatePalette;
  72.     end;
  73.   end;
  74. end;
  75.  
  76. procedure TForm1.FadeIn(Time: Integer; Col: Integer);
  77. var
  78.   t: DWORD;
  79.   i, p, o: Integer;
  80. begin
  81.   if not DXDraw1.CanDraw then Exit;
  82.   if not DXDraw1.CanPaletteAnimation then Exit;
  83.  
  84.   {  Fade in  }
  85.   t := GetTickCount;
  86.   o := 0;
  87.   while Abs(GetTickCount-t)<Time do
  88.   begin
  89.     p := 255-Min(Max(Abs(GetTickCount-t)*255 div Time, 0), 255);
  90.  
  91.     if p<>o then
  92.     begin
  93.       o := p;
  94.  
  95.       for i:=0 to 255 do
  96.         DXDraw1.ColorTable[i] := ComposeColor(RGBQuad(GetRValue(Col), GetGValue(Col), GetBValue(Col)),
  97.           DXDraw1.DefColorTable[i], p);
  98.  
  99.       DXDraw1.UpdatePalette;
  100.     end;
  101.   end;
  102. end;
  103.  
  104. procedure TForm1.Flash(Time: Integer; Col: Integer);
  105. begin
  106.   {  Flash  }
  107.   FadeOut(Time div 2, Col);
  108.   FadeIn(Time div 2, Col);
  109. end;
  110.  
  111. procedure TForm1.Button1Click(Sender: TObject);
  112. begin
  113.   FadeOut(500, RGB(0, 0, 0));
  114.  
  115.   {  The palette is returned.  }
  116.   DXDraw1.ColorTable := DXDraw1.DefColorTable;
  117.   DXDraw1.UpdatePalette;
  118. end;
  119.  
  120. procedure TForm1.Button2Click(Sender: TObject);
  121. begin
  122.   FadeIn(500, RGB(0, 0, 0));
  123. end;
  124.  
  125. procedure TForm1.Button3Click(Sender: TObject);
  126. begin
  127.   Flash(200, RGB(255, 255, 255));
  128. end;
  129.  
  130. procedure TForm1.Button4Click(Sender: TObject);
  131. begin
  132.   Close;
  133. end;
  134.  
  135. procedure TForm1.FormCreate(Sender: TObject);
  136. begin
  137.   DXImageList1.Items.MakeColorTable;
  138.   DXDraw1.DefColorTable := DXImageList1.Items.ColorTable;
  139.   DXDraw1.ColorTable := DXImageList1.Items.ColorTable;
  140. end;
  141.  
  142. procedure TForm1.DXDraw1InitializeSurface(Sender: TObject);
  143. begin
  144.   DXImageList1.Items[0].StretchDraw(DXDraw1.Surface, DXDraw1.Surface.ClientRect, 0);
  145. end;
  146.  
  147. procedure TForm1.DXDraw1RestoreSurface(Sender: TObject);
  148. begin
  149.   DXImageList1.Items[0].StretchDraw(DXDraw1.Surface, DXDraw1.Surface.ClientRect, 0);
  150. end;
  151.  
  152. end.
  153.  
  154.