home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 21 / IOPROG_21.ISO / SOFT / DBTIMAGE.ZIP / DBTransparentImage.pas
Encoding:
Pascal/Delphi Source File  |  1998-11-08  |  4.6 KB  |  146 lines
  1. unit DBTransparentImage;
  2.  
  3. {***************************************************************}
  4. {                                                               }
  5. { Transparent DBImage control for Delphi 4                      }
  6. { Paints the bitmap transparently onto its background. Note     }
  7. { that its background is not itself see through, but has the    }
  8. { colour specified in its Color property.                       }
  9. {                                                               }
  10. { Freeware by Deborah Pate                                      }
  11. { Version 1, November 1998                                      }
  12. {                                                               }
  13. { Uses the Transparent property of a TGraphic, so can't be used }
  14. { with Delphi 2 (sorry). Maybe with Delphi 3? I went straight   }
  15. { from 2 to 4, so I can't check it.                             }
  16. {                                                               }
  17. { Please send improvements, bug reports etc to me at:           }
  18. { dpate@hotmail.com                                             }
  19. {                                                               }
  20. {***************************************************************}
  21.  
  22.  
  23. interface
  24.  
  25. uses Windows, SysUtils, Messages, Classes, Controls, Forms,
  26.      Graphics, Db, DBCtrls;
  27.  
  28. type
  29.  
  30.   TDBTransparentImage = class(TDBImage)
  31.   private
  32.     fTransparent: boolean;
  33.    protected
  34.     procedure Paint; override;
  35.     procedure SetTransparent(const On: boolean);
  36.   public
  37.     constructor Create(AOwner: TComponent); override;
  38.   published
  39.     property Transparent: boolean read fTransparent
  40.                                   write SetTransparent default True;
  41.   end;
  42.  
  43. procedure Register;
  44.  
  45. implementation
  46.  
  47. procedure Register;
  48. begin
  49.   RegisterComponents('Data Controls', [TDBTransparentImage]);
  50. end;
  51.  
  52. { TDBTransparentImage }
  53.  
  54. constructor TDBTransparentImage.Create(AOwner: TComponent);
  55. begin
  56.   inherited Create(AOwner);
  57.   fTransparent := True;
  58.   ControlStyle := ControlStyle - [csOpaque];
  59. end;
  60.  
  61. procedure TDBTransparentImage.SetTransparent(const On: boolean);
  62. begin
  63.   fTransparent := On;
  64.   if On then
  65.      ControlStyle := ControlStyle - [csOpaque]
  66.   else ControlStyle := ControlStyle + [csOpaque];
  67.   Invalidate;
  68. end;
  69.  
  70. procedure TDBTransparentImage.Paint;
  71. var
  72.   Size: TSize;
  73.   R: TRect;
  74.   S: string;
  75.   DrawPict: TPicture;
  76.   Form: TCustomForm;
  77.   Pal: HPalette;
  78. begin
  79.   with Canvas do begin
  80.     Brush.Style := bsClear;
  81.     Brush.Color := Color;
  82.     if ((Picture.Graphic <> nil) or (csPaintCopy in ControlState)) then begin
  83.       DrawPict := TPicture.Create;
  84.       Pal := 0;
  85.        try
  86.         if (csPaintCopy in ControlState) and
  87.           (Field <> nil) and Field.IsBlob then begin
  88.           DrawPict.Assign(Field);
  89.           if DrawPict.Graphic is TBitmap then
  90.             DrawPict.Bitmap.IgnorePalette := QuickDraw;
  91.         end
  92.         else begin
  93.           DrawPict.Assign(Picture);
  94.           if Focused and (DrawPict.Graphic <> nil)
  95.             and (DrawPict.Graphic.Palette <> 0) then begin
  96.             { Control has focus, so realize the bitmap palette in foreground }
  97.             Pal := SelectPalette(Handle, DrawPict.Graphic.Palette, False);
  98.             RealizePalette(Handle);
  99.           end;
  100.         end;
  101.  
  102.         if (DrawPict.Graphic <> nil) then
  103.            DrawPict.Graphic.Transparent := fTransparent;
  104.  
  105.         if Stretch then
  106.           if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
  107.             FillRect(ClientRect)
  108.           else StretchDraw(ClientRect, DrawPict.Graphic)
  109.         else begin
  110.           SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
  111.           if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
  112.             (ClientHeight - DrawPict.Height) div 2);
  113.           StretchDraw(R, DrawPict.Graphic);
  114.           ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  115.           FillRect(ClientRect);
  116.           SelectClipRgn(Handle, 0);
  117.         end;
  118.       finally
  119.         if Pal <> 0 then SelectPalette(Handle, Pal, True);
  120.         DrawPict.Free;
  121.       end;
  122.     end
  123.     else begin
  124.       Font := Self.Font;
  125.       if (Field <> nil) then
  126.         S := Field.DisplayLabel
  127.       else S := Name;
  128.       S := '(' + S + ')';
  129.       Size := TextExtent(S);
  130.       R := ClientRect;
  131.       TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
  132.     end;
  133.  
  134.     Form := GetParentForm(Self);
  135.     if (Form <> nil) and (Form.ActiveControl = Self) and
  136.       not (csDesigning in ComponentState) and
  137.       not (csPaintCopy in ControlState) then
  138.     begin
  139.       Brush.Color := clWindowFrame;
  140.       FrameRect(ClientRect);
  141.     end;
  142.   end;
  143. end;
  144.  
  145. end.
  146.