home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d56 / DCHINTEX.ZIP / udcUtil.pas < prev   
Pascal/Delphi Source File  |  2001-07-03  |  3KB  |  116 lines
  1. unit udcUtil;
  2.  
  3. interface
  4. uses Windows, Graphics, Classes;
  5.  
  6. type
  7.  
  8.   TTransparentBitmap = class(TObject)
  9.   protected
  10.     procedure NewBitmap; virtual;
  11.     procedure NewTransBitmap; virtual;
  12.     procedure FreeBitmap; virtual;
  13.     procedure FreeTransBitmap; virtual;
  14.     procedure GetScreenBitmap(r: TRect); virtual;
  15.   public
  16.     Bitmap: TBitmap;
  17.     TransBitmap: TBitmap;
  18.     procedure CreateBitmap(r: TRect; Color: TColor; Level: Integer); virtual;
  19.     procedure PrepareScreenBitmap(R: TRect); virtual;
  20.     procedure ApplyTransparency(r: TRect; Color: TColor; Level: Integer); virtual;
  21.     destructor Destroy; override;
  22.   end;
  23.  
  24. implementation
  25.  
  26. procedure TTransparentBitmap.ApplyTransparency(r: TRect; Color: TColor;
  27.   Level: Integer);
  28. type
  29.   PRGBArray = ^TRGBArray;
  30.   TRGBArray = array[0..1000000] of TRGBTriple;
  31. var
  32.   SL: PRGBArray;
  33.   X, Y: Integer;
  34.   aColor: Cardinal;
  35. begin
  36.   NewTransBitmap;
  37.   TransBitmap.Width := r.Right-r.Left+1;
  38.   TransBitmap.Height := r.Bottom-r.Top+1;
  39.   BitBlt(TransBitmap.Canvas.Handle, r.Left, r.Top, r.Right, r.Bottom,
  40.     Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
  41.   aColor := ColorToRGB(Color);
  42.   for Y := 0 to TransBitmap.Height - 1 do begin
  43.     SL := TransBitmap.ScanLine[Y];
  44.     for X := 0 to TransBitmap.Width - 1 do
  45.       try
  46.        SL[X].rgbtRed := (Level * SL[X].rgbtRed + (100 -
  47.                          Level) * GetRValue(aColor)) div 100;
  48.        SL[X].rgbtGreen := (Level * SL[X].rgbtGreen + (100 -
  49.                            Level)* GetGValue(aColor)) div 100;
  50.        SL[X].rgbtBlue := (Level * SL[X].rgbtBlue + (100 -
  51.                           Level) * GetBValue(aColor)) div 100;
  52.       except
  53.       end;
  54.   end;
  55. end;
  56.  
  57. procedure TTransparentBitmap.CreateBitmap(r: TRect; Color: TColor; Level: Integer);
  58. begin
  59.   PrepareScreenBitmap(r);
  60.   ApplyTransparency(Rect(0,0, Bitmap.Width-1, Bitmap.Height-1), Color, Level);
  61. end;
  62.  
  63. destructor TTransparentBitmap.Destroy;
  64. begin
  65.   FreeBitmap;
  66.   FreeTransBitmap;
  67.   inherited;
  68. end;
  69.  
  70. procedure TTransparentBitmap.FreeBitmap;
  71. begin
  72.   Bitmap.Free;
  73. end;
  74.  
  75. procedure TTransparentBitmap.FreeTransBitmap;
  76. begin
  77.   TransBitmap.Free;
  78. end;
  79.  
  80. procedure TTransparentBitmap.GetScreenBitmap(r: TRect);
  81. var DC: HDC;
  82. begin
  83.   Bitmap.Width := r.Right-r.Left+1;
  84.   Bitmap.Height := r.Bottom-r.Top+1;
  85.   DC := GetDC(0);
  86.   try
  87.     with Bitmap do
  88.       BitBlt(Canvas.Handle, 0, 0,
  89.              Width, Height, DC, r.Left, r.Top, SrcCopy);
  90.   finally
  91.     ReleaseDC(0, DC);
  92.   end;
  93. end;
  94.  
  95. procedure TTransparentBitmap.NewBitmap;
  96. begin
  97.   FreeBitmap;
  98.   Bitmap := TBitmap.Create;
  99.   Bitmap.PixelFormat := pf24bit;
  100. end;
  101.  
  102. procedure TTransparentBitmap.NewTransBitmap;
  103. begin
  104.   FreeTransBitmap;
  105.   TransBitmap := TBitmap.Create;
  106.   TransBitmap.PixelFormat := pf24bit;
  107. end;
  108.  
  109. procedure TTransparentBitmap.PrepareScreenBitmap(r: TRect);
  110. begin
  111.   NewBitmap;
  112.   GetScreenBitmap(R);
  113. end;
  114.  
  115. end.
  116.