-
{**********************************************}
-
{ TeeChart and TeeTree Image Filters }
-
{ }
-
{ Copyright (c) 2006-2007 by David Berneda }
-
{ All Rights Reserved }
-
{**********************************************}
-
unit TeeFilters ;
-
{$I TeeDefs.inc}
-
-
{$R-}
-
-
interface
-
-
uses
-
{$IFNDEF LINUX}
-
Windows ,
-
{$ENDIF}
-
Classes ,
-
{$IFDEF D6}
-
Types ,
-
{$ENDIF}
-
{$IFDEF CLX}
-
Qt , QControls , QGraphics , QStdCtrls , QExtCtrls ,
-
{$ELSE}
-
Controls , Graphics , StdCtrls , ExtCtrls ,
-
{$ENDIF}
-
TeCanvas ;
-
-
{$IFDEF CLR}
-
{$UNSAFECODE ON}
-
{$ENDIF}
-
-
type
-
TResizeFilter = class (TTeeFilter )
-
private
-
FWidth : Integer ;
-
FHeight : Integer ;
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Width : Integer read FWidth write FWidth default 0 ;
-
property Height : Integer read FHeight write FHeight default 0 ;
-
end ;
-
-
TCropFilter = class (TResizeFilter )
-
private
-
FLeft : Integer ;
-
FSmooth : Boolean ;
-
FTop : Integer ;
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Left : Integer read FLeft write FLeft default 0 ;
-
property Smooth : Boolean read FSmooth write FSmooth default False ;
-
property Top : Integer read FTop write FTop default 0 ;
-
end ;
-
-
TInvertFilter = class (TTeeFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TGrayMethod = (gmSimple , gmEye , gmEye2 ) ;
-
-
TGrayScaleFilter = class (TTeeFilter )
-
private
-
FMethod : TGrayMethod ;
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Method :TGrayMethod read FMethod write FMethod default gmSimple ;
-
end ;
-
-
TFlipFilter = class (TTeeFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TReverseFilter = class (TTeeFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TAmountFilter = class (TTeeFilter )
-
private
-
FAmount : Integer ;
-
FPercent : Boolean ;
-
FScrollBar : TScrollBar ;
-
-
IOnlyPositive : Boolean ;
-
procedure ResetScroll (Sender : TObject ) ;
-
function ScrollMin : Integer ;
-
function ScrollMax : Integer ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
published
-
property Percent : Boolean read FPercent write FPercent default True ;
-
property Amount : Integer read FAmount write FAmount default 5 ;
-
end ;
-
-
TMosaicFilter = class (TAmountFilter )
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TBrightnessFilter = class (TAmountFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TContrastFilter = class (TAmountFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TColorFilter = class (TTeeFilter )
-
private
-
FBlue : Integer ;
-
FGreen : Integer ;
-
FRed : Integer ;
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Red : Integer read FRed write FRed default 0 ;
-
property Green : Integer read FGreen write FGreen default 0 ;
-
property Blue : Integer read FBlue write FBlue default 0 ;
-
end ;
-
-
THueLumSatFilter = class (TTeeFilter )
-
private
-
FHue : Integer ;
-
FLum : Integer ;
-
FSat : Integer ;
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Hue : Integer read FHue write FHue default 0 ;
-
property Luminance : Integer read FLum write FLum default 0 ;
-
property Saturation : Integer read FSat write FSat default 0 ;
-
end ;
-
-
TSharpenFilter = class (TConvolveFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TEmbossFilter = class (TConvolveFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TSoftenFilter = class (TConvolveFilter )
-
public
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
end ;
-
-
TGammaCorrectionFilter = class (TAmountFilter )
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Amount default 70 ;
-
end ;
-
-
TRotateFilter = class (TTeeFilter )
-
private
-
FAngle : Double ;
-
FAutoSize : Boolean ;
-
FBackColor : TColor ;
-
procedure SetAngle ( const Value : Double ) ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Angle : Double read FAngle write SetAngle ;
-
property AutoSize : Boolean read FAutoSize write FAutoSize default True ;
-
property BackColor :TColor read FBackColor write FBackColor default clWhite ;
-
end ;
-
-
TMirrorDirection = (mdDown , mdUp , mdRight , mdLeft ) ;
-
-
TMirrorFilter = class (TTeeFilter )
-
private
-
FDirection : TMirrorDirection ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Direction :TMirrorDirection read FDirection write FDirection
-
default mdDown ;
-
end ;
-
-
TTileFilter = class (TTeeFilter )
-
private
-
FNumCols : Integer ;
-
FNumRows : Integer ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
-
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property NumCols : Integer read FNumCols write FNumCols default 3 ;
-
property NumRows : Integer read FNumRows write FNumRows default 3 ;
-
end ;
-
-
TBevelFilter = class (TTeeFilter )
-
private
-
FBright : Integer ;
-
FSize : Integer ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
-
procedure Apply (Bitmap : TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Bright : Integer read FBright write FBright default 64 ;
-
property Size : Integer read FSize write FSize default 15 ;
-
end ;
-
-
TZoomFilter = class (TTeeFilter )
-
private
-
FPercent : Double ;
-
FSmooth : Boolean ;
-
public
-
Constructor Create (Collection :TCollection ) ; override ;
-
-
procedure Apply (Bitmap : TBitmap ; const R :TRect ) ; override ;
-
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
-
class function Description : String ; override ;
-
published
-
property Percent : Double read FPercent write FPercent ;
-
property Smooth : Boolean read FSmooth write FSmooth default False ;
-
end ;
-
-
TImageFiltered = class (TImage )
-
private
-
FFilters : TFilterItems ;
-
-
function FiltersStored : Boolean ;
-
procedure ReadFilters (Reader : TReader ) ;
-
procedure SetFilters ( const Value : TFilterItems ) ;
-
procedure WriteFilters (Writer : TWriter ) ;
-
protected
-
procedure DefineProperties (Filer :TFiler ) ; override ;
-
procedure Paint ; override ;
-
public
-
Constructor Create (AOwner :TComponent ) ; override ;
-
Destructor Destroy ; override ;
-
-
function Filtered :TBitmap ;
-
published
-
property Filters :TFilterItems read FFilters write SetFilters stored False ;
-
end ;
-
-
var
-
FilterClasses : TList ;
-
-
procedure TeeRegisterFilters ( const FilterList : Array of TFilterClass ) ;
-
procedure TeeUnRegisterFilters ( const FilterList : Array of TFilterClass ) ;
-
-
procedure ColorToHLS (Color : TColor ; out Hue , Luminance , Saturation : Word ) ;
-
procedure RGBToHLS ( const Color : TRGB ; out Hue , Luminance , Saturation : Word ) ;
-
-
procedure HLSToRGB (Hue , Luminance , Saturation : Word ; out rgb : TRGB ) ;
-
function HLSToColor (Hue , Luminance , Saturation : Word ) :TColor ;
-
-
// Converts ABitmap pixels into Gray Scale (levels of gray) v5.02 (v8 moved from TeCanvas.pas)
-
Procedure TeeGrayScale (ABitmap :TBitmap ; Inverted : Boolean ; AMethod : Integer ) ;
-
-
implementation
-
-
uses
-
Math , SysUtils , TypInfo , TeeConst ;
-
-
procedure TeeRegisterFilters ( const FilterList : Array of TFilterClass ) ;
-
var t : Integer ;
-
begin
-
if not Assigned (FilterClasses ) then
-
FilterClasses : =TList . Create ;
-
-
for t : = Low (FilterList ) to High (FilterList ) do
-
if FilterClasses . IndexOf ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) =- 1 then
-
begin
-
FilterClasses . Add ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) ;
-
RegisterClass (FilterList [t ] ) ;
-
end ;
-
end ;
-
-
procedure TeeUnRegisterFilters ( const FilterList : Array of TFilterClass ) ;
-
var t : Integer ;
-
begin
-
if Assigned (FilterClasses ) then
-
for t : = Low (FilterList ) to High (FilterList ) do
-
FilterClasses . Remove ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) ;
-
end ;
-
-
{ TResizeFilter }
-
-
function SmoothBitmap (Bitmap :TBitmap ; Width ,Height : Integer ) :TBitmap ;
-
begin
-
result : =TBitmap . Create ;
-
TeeSetBitmapSize (result ,Width ,Height ) ;
-
SmoothStretch (Bitmap ,result ) ;
-
end ;
-
-
procedure TResizeFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
-
var tmp : TBitmap ;
-
begin
-
if (Width> 0 ) and (Height> 0 ) then
-
begin
-
tmp : =SmoothBitmap (Bitmap ,Width ,Height ) ;
-
try
-
TeeSetBitmapSize (Bitmap ,Width ,Height ) ;
-
Bitmap . Canvas . Draw ( 0 , 0 ,tmp ) ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
// Do not call inherited;
-
end ;
-
-
procedure TResizeFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddInteger ( 'Width' ,TeeMsg_Width , 0 , 10000 ) ; // Do not localize
-
Creator . AddInteger ( 'Height' ,TeeMsg_Height , 0 , 10000 ) ; // Do not localize
-
end ;
-
-
class function TResizeFilter . Description : String ;
-
begin
-
result : =TeeMsg_Resize ;
-
end ;
-
-
{ TCropFilter }
-
-
procedure TCropFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
-
var tmp : TBitmap ;
-
begin
-
if (Width> 0 ) and (Height> 0 ) then
-
begin
-
tmp : =TBitmap . Create ;
-
try
-
tmp . PixelFormat : =Bitmap . PixelFormat ;
-
TeeSetBitmapSize (tmp ,Width ,Height ) ;
-
-
tmp . Canvas . CopyRect (TeeRect ( 0 , 0 ,tmp . Width ,tmp . Height ) ,
-
Bitmap . Canvas ,TeeRect (Left ,Top ,Left +Width - 1 ,Top +Height - 1 ) ) ;
-
-
if FSmooth then
-
SmoothStretch (tmp ,Bitmap )
-
else
-
Bitmap . Canvas . StretchDraw (TeeRect ( 0 , 0 ,Bitmap . Width - 1 ,Bitmap . Height - 1 ) ,tmp ) ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
-
// Do not call inherited;
-
end ;
-
-
procedure TCropFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddInteger ( 'Left' ,TeeMsg_Left , 0 , 10000 ) ; // Do not localize
-
Creator . AddInteger ( 'Top' ,TeeMsg_Top , 0 , 10000 ) ; // Do not localize
-
Creator . AddCheckBox ( 'Smooth' ,TeeMsg_Smooth ) ; // Do not localize
-
end ;
-
-
class function TCropFilter . Description : String ;
-
begin
-
result : =TeeMsg_Crop ;
-
end ;
-
-
{ TInvertFilter }
-
procedure TInvertFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
-
var x ,y : Integer ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
Blue : = 255 -Blue ;
-
Green : = 255 -Green ;
-
Red : = 255 -Red ;
-
end ;
-
end ;
-
-
class function TInvertFilter . Description : String ;
-
begin
-
result : =TeeMsg_Invert ;
-
end ;
-
-
{ TGrayScaleFilter }
-
procedure TGrayScaleFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
-
var x ,y : Integer ;
-
tmp : Byte ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
case Method of
-
gmSimple : for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
tmp : = (Blue +Green +Red ) div 3 ;
-
Blue : =tmp ;
-
Green : =tmp ;
-
Red : =tmp ;
-
end ;
-
gmEye : for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
tmp : = Round ( ( 0.30 *Red ) +
-
( 0.59 *Green ) +
-
( 0.11 *Blue ) ) ;
-
-
Blue : =tmp ;
-
Green : =tmp ;
-
Red : =tmp ;
-
end ;
-
gmEye2 : for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
tmp : = ( 11 *Red + 16 *Green + 5 *Blue ) div 32 ;
-
Blue : =tmp ;
-
Green : =tmp ;
-
Red : =tmp ;
-
end ;
-
end ;
-
end ;
-
-
procedure TGrayScaleFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddCombo ( 'Method' ) ; // Do not localize
-
end ;
-
-
class function TGrayScaleFilter . Description : String ;
-
begin
-
result : =TeeMsg_GrayScale ;
-
end ;
-
-
{ TMosaicFilter }
-
constructor TMosaicFilter . Create (Collection :TCollection ) ;
-
begin
-
inherited ;
-
FAmount : = 8 ;
-
IOnlyPositive : = True ;
-
end ;
-
-
procedure TMosaicFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
var
-
tmpAmountX : Integer ;
-
tmpAmountY : Integer ;
-
tmpDims : Single ;
-
-
procedure DoMosaic ( const tmpX ,tmpY : Integer ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
var ar ,
-
ag ,
-
ab : Integer ;
-
xx ,
-
yy : Integer ;
-
a : TRGB ;
-
Line : PRGBs ;
-
begin
-
ar : = 0 ;
-
ag : = 0 ;
-
ab : = 0 ;
-
-
for yy : = 0 to tmpAmountY do
-
begin
-
Line : =Lines [tmpY +yy ] ;
-
-
for xx : = 0 to tmpAmountX do
-
with Line [tmpX +xx ] do
-
begin
-
Inc (ar ,Red ) ;
-
Inc (ag ,Green ) ;
-
Inc (ab ,Blue ) ;
-
end ;
-
end ;
-
-
a . Red : = Round (ar *tmpDims ) ;
-
a . Green : = Round (ag *tmpDims ) ;
-
a . Blue : = Round (ab *tmpDims ) ;
-
-
for yy : = 0 to tmpAmountY do
-
begin
-
Line : =Lines [tmpY +yy ] ;
-
for xx : = 0 to tmpAmountX do
-
Line [tmpX +xx ] : =a ;
-
end ;
-
end ;
-
-
procedure DoMosaicRow ( const tmpY : Integer ) ;
-
var tmpX : Integer ;
-
begin
-
tmpX : =R . Left ;
-
while tmpX<R . Right -Amount do
-
begin
-
DoMosaic (tmpX ,tmpY ) ;
-
Inc (tmpX ,Amount ) ;
-
end ;
-
-
// Remainder horizontal mosaic cell
-
if tmpX<R . Right then
-
begin
-
tmpAmountX : =R . Right -tmpX ;
-
tmpDims : = 1.0 / ( Succ (tmpAmountX ) * Succ (tmpAmountY ) ) ;
-
-
DoMosaic (tmpX ,tmpY ) ;
-
-
tmpAmountX : =tmpAmountY ;
-
tmpDims : = 1.0 / Sqr (Amount ) ;
-
end ;
-
end ;
-
-
var tmpY : Integer ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if Amount> 0 then
-
begin
-
tmpDims : = 1.0 / Sqr (Amount ) ;
-
tmpAmountX : =Amount - 1 ;
-
tmpAmountY : =tmpAmountX ;
-
-
tmpY : =R . Top ;
-
while tmpY<R . Bottom -Amount do
-
begin
-
DoMosaicRow (tmpY ) ;
-
Inc (tmpY ,Amount ) ;
-
end ;
-
-
// Remainder vertical mosaic row cells
-
if tmpY<R . Bottom then
-
begin
-
tmpAmountY : =R . Bottom -tmpY - 1 ;
-
tmpDims : = 1.0 / ( Succ (tmpAmountX ) * Succ (tmpAmountY ) ) ;
-
DoMosaicRow (tmpY ) ;
-
end ;
-
end ;
-
end ;
-
-
class function TMosaicFilter . Description : String ;
-
begin
-
result : =TeeMsg_Mosaic ;
-
end ;
-
-
{ TFlipFilter }
-
procedure TFlipFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
var tmp : TRGB ;
-
tmpH ,
-
tmpY ,
-
x ,y : Integer ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
tmpH : =R . Bottom -R . Top ;
-
-
for y : =R . Top to R . Top + (tmpH div 2 ) - 1 do
-
for x : =R . Left to R . Right do
-
begin
-
tmp : =Lines [y ,x ] ;
-
tmpY : =tmpH -y ;
-
Lines [y ,x ] : =Lines [tmpY ,x ] ;
-
Lines [tmpY ,x ] : =tmp ;
-
end ;
-
end ;
-
-
class function TFlipFilter . Description : String ;
-
begin
-
result : =TeeMsg_Flip ;
-
end ;
-
-
{ TReverseFilter }
-
procedure TReverseFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
-
var tmp : TRGB ;
-
tmpW ,
-
tmpX ,
-
x ,y : Integer ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
tmpW : =R . Right -R . Left ;
-
-
for x : =R . Left to R . Left + (tmpW div 2 ) - 1 do
-
for y : =R . Top to R . Bottom do
-
begin
-
tmp : =Lines [y ,x ] ;
-
tmpX : =tmpW -x ;
-
Lines [y ,x ] : =Lines [y ,tmpX ] ;
-
Lines [y ,tmpX ] : =tmp ;
-
end ;
-
end ;
-
-
class function TReverseFilter . Description : String ;
-
begin
-
result : =TeeMsg_Reverse ;
-
end ;
-
-
{ TAmountFilter }
-
Constructor TAmountFilter . Create (Collection :TCollection ) ;
-
begin
-
inherited ;
-
FPercent : = True ;
-
FAmount : = 5 ; // %
-
end ;
-
-
function TAmountFilter . ScrollMin : Integer ;
-
begin
-
if FPercent then
-
if IOnlyPositive then result : = 0 else result : =- 100
-
else
-
if IOnlyPositive then result : = 0 else result : =- 255 ;
-
end ;
-
-
function TAmountFilter . ScrollMax : Integer ;
-
begin
-
if FPercent then result : = 100
-
else result : = 255 ;
-
end ;
-
-
procedure TAmountFilter . ResetScroll (Sender : TObject ) ;
-
begin
-
FScrollBar . Min : =ScrollMin ;
-
FScrollBar . Max : =ScrollMax ;
-
end ;
-
-
procedure TAmountFilter . CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ;
-
begin
-
inherited ;
-
FScrollBar : =Creator . AddScroll ( 'Amount' ,ScrollMin ,ScrollMax ) ; // Do not localize
-
Creator . AddCheckBox ( 'Percent' ,TeeMsg_Percent ,ResetScroll ) ; // Do not localize
-
end ;
-
-
{ TBrightnessFilter }
-
procedure TBrightnessFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
var x ,y ,l : Integer ;
-
IPercent : Single ;
-
begin
-
if Amount = 0 then
-
Exit ;
-
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if Percent then
-
begin
-
IPercent : =FAmount * 0.01 ;
-
-
for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
l : =Red + Round ( 255 *IPercent ) ;
-
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
-
-
l : =Green + Round ( 255 *IPercent ) ;
-
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
-
-
l : =Blue + Round ( 255 *IPercent ) ;
-
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
-
end ;
-
end
-
else
-
for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
l : =Red +Amount ;
-
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
-
-
l : =Green +Amount ;
-
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
-
-
l : =Blue +Amount ;
-
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
-
end ;
-
end ;
-
-
class function TBrightnessFilter . Description : String ;
-
begin
-
result : =TeeMsg_Brightness ;
-
end ;
-
-
procedure ColorToHLS (Color : TColor ; out Hue , Luminance , Saturation : Word ) ;
-
var tmp : TRGB ;
-
begin
-
Color : =ColorToRGB (Color ) ;
-
tmp . Red : =GetRValue (Color ) ;
-
tmp . Green : =GetGValue (Color ) ;
-
tmp . Blue : =GetBValue (Color ) ;
-
RGBToHLS (tmp ,Hue ,Luminance ,Saturation ) ;
-
end ;
-
-
type
-
Float = Single ;
-
-
const
-
// HLSMAX BEST IF DIVISIBLE BY 6. RGBMAX, HLSMAX must each fit in a byte.
-
HLSMAX = 240 ; // H,L, and S vary over 0-HLSMAX
-
RGBMAX = 255 ; // R,G, and B vary over 0-RGBMAX
-
-
RGBMAX2 = 2.0 *RGBMAX ;
-
InvRGBMAX2 = 1.0 /RGBMAX2 ;
-
-
HLSMAXDiv2 =HLSMAX / 2 ;
-
HLSMAXDiv3 =HLSMAX / 3 ;
-
HLSMAXDiv6 =HLSMAX / 6 ;
-
HLSMAXDiv12 =HLSMAX / 12 ;
-
HLSMAX2 =HLSMAX * 2 ;
-
HLSMAX3 =HLSMAX * 3 ;
-
HLSMAX2Div3 =HLSMAX2 / 3 ;
-
-
{ Hue is undefined if Saturation is 0 (grey-scale)
-
This value determines where the Hue scrollbar is
-
initially set for achromatic colors }
-
HLSUndefined = 160 ; // HLSMAX2Div3;
-
-
procedure RGBToHLS ( const Color : TRGB ; out Hue , Luminance , Saturation : Word ) ;
-
var
-
H , L , S : Float ;
-
R , G , B : Word ;
-
dif : Integer ;
-
sum , cMax , cMin : Word ;
-
Rdelta , Gdelta , Bdelta : Extended ; { intermediate value: % of spread from max }
-
begin
-
R : =Color . Red ;
-
G : =Color . Green ;
-
B : =Color . Blue ;
-
-
{ calculate lightness }
-
if R>G then
-
if R>B then cMax : =R else cMax : =B
-
else
-
if G>B then cMax : =G else cMax : =B ;
-
-
if R<G then
-
if R<B then cMin : =R else cMin : =B
-
else
-
if G<B then cMin : =G else cMin : =B ;
-
-
sum : = (cMax + cMin ) ;
-
-
L : = ( ( sum * HLSMAX ) + RGBMAX ) / ( 2 * RGBMAX ) ;
-
-
if cMax = cMin then { r=g=b --> achromatic case }
-
begin { saturation }
-
Hue : = Round (HLSUndefined ) ;
-
// pwHue := 160; { MS ColoroHLS always defaults to 160 in this case }
-
Luminance : = Round (L ) ;
-
Saturation : = 0 ;
-
end
-
else { chromatic case }
-
begin
-
dif : =cMax -cMin ;
-
-
{ saturation }
-
if L < = HLSMAXDiv2 then
-
S : = ( (dif *HLSMAX ) + ( sum * 0.5 ) ) / sum
-
else
-
S : = ( (dif *HLSMAX ) + ( RGBMAX - ( sum * 0.5 ) ) ) / ( 2 *RGBMAX - sum ) ;
-
-
{ hue }
-
Rdelta : = ( ( (cMax -R ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
-
Gdelta : = ( ( (cMax -G ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
-
Bdelta : = ( ( (cMax -B ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
-
-
if R = cMax then
-
H : = Bdelta - Gdelta
-
else
-
if G = cMax then
-
H : = HLSMAX3 + Rdelta - Bdelta
-
else // B == cMax
-
H : = HLSUndefined + Gdelta - Rdelta ;
-
-
if H < 0 then H : = H + HLSMAX
-
else
-
if H > HLSMAX then H : = H - HLSMAX ;
-
-
Hue : = Round (H ) ;
-
Luminance : = Round (L ) ;
-
Saturation : = Round (S ) ;
-
end ;
-
end ;
-
-
function HLSToColor (Hue , Luminance , Saturation : Word ) :TColor ;
-
var tmp : TRGB ;
-
begin
-
HLSToRGB (Hue ,Luminance ,Saturation ,tmp ) ;
-
result : =RGB (tmp . Red ,tmp . Green ,tmp . Blue ) ;
-
end ;
-
-
procedure HLSToRGB (Hue , Luminance , Saturation : Word ; out rgb : TRGB ) ;
-
-
function HueToRGB ( const Lum , Sat :Float ; Hue : Float ) : Integer ;
-
begin
-
{ range check: note values passed add/subtract thirds of range }
-
if hue < 0 then hue : =hue +HLSMAX ;
-
if hue > HLSMAX then hue : =hue -HLSMAX ;
-
-
{ return r,g, or b value from this tridrant }
-
if hue < HLSMAXDiv6 then
-
Result : = Round ( Lum + ( ( (Sat -Lum ) *hue +HLSMAXDiv12 ) /HLSMAXDiv6 ) )
-
else
-
if hue < HLSMAXDiv2 then
-
Result : = Round ( Sat )
-
else
-
if hue < HLSMAX2Div3 then
-
Result : = Round ( Lum + ( ( (Sat -Lum ) * (HLSMAX2Div3 -hue ) +HLSMAXDiv12 ) /HLSMAXDiv6 ) )
-
else
-
Result : = Round ( Lum ) ;
-
end ;
-
-
function RoundColor ( const Value : Integer ) : Integer ;
-
begin
-
if Value > 255 then Result : = 255 else Result : = Round (Value ) ;
-
end ;
-
-
var
-
Magic1 , Magic2 : Float ; { calculated magic numbers (really!) }
-
-
function RoundColor2 ( const Hue : Float ) : Integer ;
-
begin
-
result : =RoundColor ( Round ( (HueToRGB (Magic1 ,Magic2 ,Hue ) *RGBMAX + HLSMAXDiv2 ) /HLSMAX ) ) ;
-
end ;
-
-
begin
-
if Saturation = 0 then
-
with rgb do
-
begin { achromatic case }
-
Red : = RoundColor ( Round ( (Luminance * RGBMAX ) /HLSMAX ) ) ;
-
Green : =Red ;
-
Blue : =Green ;
-
if Hue <> HLSUndefined then ; { ERROR }
-
end
-
else
-
begin { chromatic case }
-
{ set up magic numbers }
-
if Luminance < = HLSMAXDiv2 then
-
Magic2 : = (Luminance * (HLSMAX + Saturation ) + HLSMAXDiv2 ) / HLSMAX
-
else
-
Magic2 : = Luminance + Saturation - ( (Luminance * Saturation ) + HLSMAXDiv2 ) / HLSMAX ;
-
-
Magic1 : = 2 * Luminance - Magic2 ;
-
-
{ get RGB, change units from HLSMAX to RGBMAX }
-
rgb . Red : =RoundColor2 (Hue +HLSMAXDiv3 ) ;
-
rgb . Green : =RoundColor2 (Hue ) ;
-
rgb . Blue : =RoundColor2 (Hue -HLSMAXDiv3 ) ;
-
end ;
-
end ;
-
-
{ TColorFilter }
-
-
procedure TColorFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
var x ,y : Integer ;
-
tmpInt : Integer ;
-
Line : PRGBs ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if (Red<> 0 ) or (Green<> 0 ) or (Blue<> 0 ) then
-
for y : =R . Top to R . Bottom do
-
begin
-
Line : =Lines [y ] ;
-
-
for x : =R . Left to R . Right do
-
with Line [x ] do
-
begin
-
if Self . FRed<> 0 then
-
begin
-
tmpInt : =Red + Self . FRed ;
-
if tmpInt< 0 then Red : = 0 else
-
if tmpInt> 255 then Red : = 255 else
-
Red : =tmpInt ;
-
end ;
-
-
if Self . FGreen<> 0 then
-
begin
-
tmpInt : =Green + Self . FGreen ;
-
if tmpInt< 0 then Green : = 0 else
-
if tmpInt> 255 then Green : = 255 else
-
Green : =tmpInt ;
-
end ;
-
-
if Self . FBlue<> 0 then
-
begin
-
tmpInt : =Blue + Self . FBlue ;
-
if tmpInt< 0 then Blue : = 0 else
-
if tmpInt> 255 then Blue : = 255 else
-
Blue : =tmpInt ;
-
end ;
-
end ;
-
end ;
-
end ;
-
-
procedure TColorFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddScroll ( 'Red' , - 255 , 255 ) ; // Do not localize
-
Creator . AddScroll ( 'Green' , - 255 , 255 ) ; // Do not localize
-
Creator . AddScroll ( 'Blue' , - 255 , 255 ) ; // Do not localize
-
end ;
-
-
class function TColorFilter . Description : String ;
-
begin
-
result : =TeeMsg_Color ;
-
end ;
-
-
{ THueLumSatFilter }
-
-
procedure THueLumSatFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
var x ,y : Integer ;
-
tmpInt : Integer ;
-
tmpHue : Word ;
-
tmpLum : Word ;
-
tmpSat : Word ;
-
Line : PRGBs ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if (FHue<> 0 ) or (FLum<> 0 ) or (FSat<> 0 ) then
-
for y : =R . Top to R . Bottom do
-
begin
-
Line : =Lines [y ] ;
-
-
for x : =R . Left to R . Right do
-
begin
-
RGBToHLS (Line [x ] ,tmpHue ,tmpLum ,tmpSat ) ;
-
-
if Self . FHue<> 0 then
-
begin
-
tmpInt : =tmpHue + Self . FHue ;
-
if tmpInt< 0 then tmpHue : = 0 else
-
if tmpInt> 255 then tmpHue : = 255 else
-
tmpHue : =tmpInt ;
-
end ;
-
-
if Self . FLum<> 0 then
-
begin
-
tmpInt : =tmpLum + Self . FLum ;
-
if tmpInt< 0 then tmpLum : = 0 else
-
if tmpInt> 255 then tmpLum : = 255 else
-
tmpLum : =tmpInt ;
-
end ;
-
-
if Self . FSat<> 0 then
-
begin
-
tmpInt : =tmpSat + Self . FSat ;
-
if tmpInt< 0 then tmpSat : = 0 else
-
if tmpInt> 255 then tmpSat : = 255 else
-
tmpSat : =tmpInt ;
-
end ;
-
-
HLSToRGB (tmpHue ,tmpLum ,tmpSat ,Line [x ] ) ;
-
end ;
-
end ;
-
end ;
-
-
procedure THueLumSatFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddScroll ( 'Hue' , - 255 , 255 ) ; // Do not localize
-
Creator . AddScroll ( 'Luminance' , - 255 , 255 ) ; // Do not localize
-
Creator . AddScroll ( 'Saturation' , - 255 , 255 ) ; // Do not localize
-
end ;
-
-
class function THueLumSatFilter . Description : String ;
-
begin
-
result : =TeeMsg_HueLumSat ;
-
end ;
-
-
{ TSharpenFilter }
-
-
procedure TSharpenFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
const Center = 2.0 ;
-
Pix =- ( (Center - 1 ) / 8.0 ) ;
-
begin
-
Weights [ - 1 , - 1 ] : =Pix ; Weights [ - 1 , 0 ] : =Pix ; Weights [ - 1 , 1 ] : =Pix ;
-
Weights [ 0 , - 1 ] : =Pix ; Weights [ 0 , 0 ] : =Center ; Weights [ 0 , 1 ] : =Pix ;
-
Weights [ 1 , - 1 ] : =Pix ; Weights [ 1 , 0 ] : =Pix ; Weights [ 1 , 1 ] : =Pix ;
-
-
InvTotalWeight : = 1.0 / 16.0 ;
-
-
inherited ;
-
end ;
-
-
class function TSharpenFilter . Description : String ;
-
begin
-
result : =TeeMsg_Sharpen ;
-
end ;
-
-
{ TGammaCorrectionFilter }
-
Constructor TGammaCorrectionFilter . Create (Collection :TCollection ) ;
-
begin
-
inherited ;
-
FAmount : = 70 ;
-
IOnlyPositive : = True ;
-
end ;
-
-
procedure TGammaCorrectionFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
var t ,
-
x ,y : Integer ;
-
IGamma : Array [ 0 .. 255 ] of Byte ;
-
tmp : Single ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
tmp : = Max ( 0.001 , Abs (Amount ) * 0.01 ) ;
-
-
IGamma [ 0 ] : = 0 ;
-
for t : = 1 to 255 do
-
IGamma [t ] : = Round ( Exp ( Ln (t / 255.0 ) /tmp ) * 255.0 ) ;
-
-
for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
Red : =IGamma [Red ] ;
-
Green : =IGamma [Green ] ;
-
Blue : =IGamma [Blue ] ;
-
end ;
-
end ;
-
-
class function TGammaCorrectionFilter . Description : String ;
-
begin
-
result : =TeeMsg_GammaCorrection ;
-
end ;
-
-
{ TEmbossFilter }
-
-
procedure TEmbossFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
begin
-
Weights [ - 1 , - 1 ] : = 0 ; Weights [ - 1 , 0 ] : =- 1 ; Weights [ - 1 , 1 ] : = 0 ;
-
Weights [ 0 , - 1 ] : =- 1 ; Weights [ 0 , 0 ] : = 1 ; Weights [ 0 , 1 ] : = 1 ;
-
Weights [ 1 , - 1 ] : = 0 ; Weights [ 1 , 0 ] : =- 1 ; Weights [ 1 , 1 ] : = 0 ;
-
-
InvTotalWeight : = 1.0 / 1.0 ;
-
-
inherited ;
-
end ;
-
-
class function TEmbossFilter . Description : String ;
-
begin
-
result : =TeeMsg_Emboss ;
-
end ;
-
-
{ TContrastFilter }
-
-
procedure TContrastFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
var x ,y ,l : Integer ;
-
IPercent : Single ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if Percent then
-
IPercent : =FAmount * 0.01
-
else
-
IPercent : = 1 ;
-
-
for y : =R . Top to R . Bottom do
-
for x : =R . Left to R . Right do
-
with Lines [y ,x ] do
-
begin
-
if Percent then l : =Red + ( Round (Red *IPercent ) * (Red - 128 ) div 256 )
-
else l : =Red + (Amount * (Red - 128 ) div 256 ) ;
-
-
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
-
-
if Percent then l : =Green + ( Round (Green *IPercent ) * (Green - 128 ) div 256 )
-
else l : =Green + (Amount * (Green - 128 ) div 256 ) ;
-
-
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
-
-
if Percent then l : =Blue + ( Round (Blue *IPercent ) * (Blue - 128 ) div 256 )
-
else l : =Blue + (Amount * (Blue - 128 ) div 256 ) ;
-
-
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
-
end ;
-
end ;
-
-
class function TContrastFilter . Description : String ;
-
begin
-
result : =TeeMsg_Contrast ;
-
end ;
-
-
{ TSoftenFilter }
-
-
procedure TSoftenFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
-
begin
-
Weights [ - 1 , - 1 ] : = 0 ; Weights [ - 1 , 0 ] : = 0 ; Weights [ - 1 , 1 ] : = 0 ;
-
Weights [ 0 , - 1 ] : = 0 ; Weights [ 0 , 0 ] : = 1 ; Weights [ 0 , 1 ] : = 1 ;
-
Weights [ 1 , - 1 ] : = 0 ; Weights [ 1 , 0 ] : = 1 ; Weights [ 1 , 1 ] : = 1 ;
-
-
InvTotalWeight : = 1.0 / 4.0 ;
-
-
inherited ;
-
end ;
-
-
class function TSoftenFilter . Description : String ;
-
begin
-
result : =TeeMsg_AntiAlias ;
-
end ;
-
-
{ TImageFiltered }
-
-
Constructor TImageFiltered . Create (AOwner : TComponent ) ;
-
begin
-
inherited ;
-
FFilters : =TFilterItems . Create ( Self ,TTeeFilter ) ;
-
end ;
-
-
Destructor TImageFiltered . Destroy ;
-
begin
-
FFilters . Free ;
-
inherited ;
-
end ;
-
-
function TImageFiltered . Filtered :TBitmap ;
-
var tmpDest : TBitmap ;
-
tmpR : TRect ;
-
tmpW : Integer ;
-
tmpH : Integer ;
-
begin
-
result : =TBitmap . Create ;
-
result . Assign (Picture . Graphic ) ;
-
-
tmpR : =DestRect ;
-
tmpW : =tmpR . Right -tmpR . Left ;
-
tmpH : =tmpR . Bottom -tmpR . Top ;
-
-
if (tmpW<>result . Width ) or (tmpH<>result . Height ) then
-
begin
-
tmpDest : =SmoothBitmap (result ,tmpW ,tmpH ) ;
-
result . Free ;
-
result : =tmpDest ;
-
end ;
-
-
FFilters . ApplyTo (result ) ;
-
end ;
-
-
procedure TImageFiltered . SetFilters ( const Value : TFilterItems ) ;
-
begin
-
FFilters . Assign (Value ) ;
-
end ;
-
-
procedure TImageFiltered . Paint ;
-
var tmpCanvas : TCanvas ;
-
tmp : TGraphic ;
-
begin
-
tmp : =Filtered ;
-
try
-
tmpCanvas : =TControlCanvas . Create ;
-
try
-
TControlCanvas (tmpCanvas ) . Control : = Self ;
-
tmpCanvas . Draw ( 0 , 0 ,tmp ) ;
-
-
if csDesigning in ComponentState then
-
with tmpCanvas do
-
begin
-
Pen . Style : =psDash ;
-
Brush . Style : =bsClear ;
-
-
{$IFDEF CLX}
-
Start ;
-
QPainter_setBackgroundMode (Handle ,BGMode_TransparentMode ) ;
-
Stop ;
-
{$ELSE}
-
SetBkMode (Handle ,Windows . TRANSPARENT ) ;
-
{$ENDIF}
-
-
with ClientRect do
-
Rectangle (Left ,Top ,Right ,Bottom ) ;
-
end ;
-
finally
-
tmpCanvas . Free ;
-
end ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
-
procedure TImageFiltered . ReadFilters (Reader : TReader ) ;
-
begin
-
TTeePicture . ReadFilters (Reader ,Filters ) ;
-
end ;
-
-
procedure TImageFiltered . WriteFilters (Writer : TWriter ) ;
-
begin
-
TTeePicture . WriteFilters (Writer ,Filters ) ;
-
end ;
-
-
function TImageFiltered . FiltersStored : Boolean ;
-
begin
-
result : = Assigned (FFilters ) and (FFilters . Count> 0 ) ;
-
end ;
-
-
procedure TImageFiltered . DefineProperties (Filer : TFiler ) ;
-
begin
-
inherited ;
-
Filer . DefineProperty ( 'FilterItems' ,ReadFilters ,WriteFilters ,FiltersStored ) ; // Do not localize
-
end ;
-
-
{ TRotateFilter }
-
-
Constructor TRotateFilter . Create (Collection :TCollection ) ;
-
begin
-
inherited ;
-
FBackColor : =clWhite ;
-
FAutoSize : = True ;
-
end ;
-
-
procedure TRotateFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
-
const
-
TeePiStep : Single = Pi / 180.0 ;
-
-
var tmp : TBitmap ;
-
x ,
-
y ,
-
xc ,
-
yc ,
-
xxc ,
-
yyc ,
-
tmpY ,
-
tmpX ,
-
h ,
-
w : Integer ;
-
-
f2 : TTeeFilter ;
-
-
f2Lines : PRGBs ;
-
-
xx ,
-
yy : Integer ;
-
-
tmpSin ,
-
tmpCos ,
-
tmpYSin ,
-
tmpYCos : Single ;
-
-
Sin ,
-
Cos : Extended ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
while Angle> 360 do
-
FAngle : =Angle - 360 ;
-
-
if Angle = 180 then
-
begin
-
TFlipFilter . ApplyTo (Bitmap ) ;
-
TReverseFilter . ApplyTo (Bitmap ) ;
-
end
-
else
-
if Angle<> 0 then
-
begin
-
tmp : =TBitmap . Create ;
-
try
-
h : =Bitmap . Height ;
-
w : =Bitmap . Width ;
-
-
if (Angle = 90 ) or (Angle = 270 ) then
-
TeeSetBitmapSize (tmp ,h ,w )
-
else
-
begin
-
SinCos ( ( 360 -Angle ) *TeePiStep , Sin , Cos ) ;
-
-
if AutoSize then
-
begin
-
if Sin *Cos> 0 then
-
TeeSetBitmapSize (tmp , Abs ( Round (w * Cos +h * Sin ) ) ,
-
Abs ( Round (w * Sin +h * Cos ) ) )
-
else
-
TeeSetBitmapSize (tmp , Abs ( Round (w *Cos -h * Sin ) ) ,
-
Abs ( Round (w *Sin -h * Cos ) ) ) ;
-
end
-
else
-
TeeSetBitmapSize (tmp ,w ,h ) ;
-
end ;
-
-
if (w> 1 ) and (h> 1 ) then
-
begin
-
if BackColor =clNone then
-
tmp . Transparent : = True
-
else
-
if BackColor<>clWhite then
-
with tmp . Canvas do
-
begin
-
Brush . Style : =bsSolid ;
-
Brush . Color : =FBackColor ;
-
FillRect (TeeRect ( 0 , 0 ,tmp . Width ,tmp . Height ) ) ;
-
end ;
-
-
f2 : =TTeeFilter . Create ( nil ) ;
-
try
-
f2 . Apply (tmp ) ;
-
-
if Angle = 90 then
-
begin
-
for y : = 0 to h - 1 do
-
for x : = 0 to w - 1 do
-
f2 . Lines [x ,h -y - 1 ] : =Lines [y ,x ] ;
-
end
-
else
-
if Angle = 270 then
-
begin
-
for y : = 0 to h - 1 do
-
for x : = 0 to w - 1 do
-
f2 . Lines [w -x - 1 ,y ] : =Lines [y ,x ] ;
-
end
-
else
-
begin
-
xxc : =tmp . Width div 2 ;
-
yyc : =tmp . Height div 2 ;
-
-
xc : =w div 2 ;
-
yc : =h div 2 ;
-
-
tmpSin : = Sin ;
-
tmpCos : = Cos ;
-
-
tmpY : =-yyc - 1 ;
-
-
for y : = 0 to tmp . Height - 1 do
-
begin
-
Inc (tmpY ) ;
-
tmpYSin : = (tmpY *tmpSin ) -xc ;
-
tmpYCos : = (tmpY *tmpCos ) +yc ;
-
-
f2Lines : =f2 . Lines [y ] ;
-
-
tmpX : =-xxc - 1 ;
-
-
for x : = 0 to tmp . Width - 1 do
-
begin
-
Inc (tmpX ) ;
-
-
xx : = Round (tmpX *tmpCos -tmpYSin ) ;
-
-
if (xx> = 0 ) and (xx<w ) then
-
begin
-
yy : = Round (tmpX *tmpSin +tmpYCos ) ;
-
-
if (yy> = 0 ) and (yy<h ) then
-
f2Lines [x ] : =Lines [yy ,xx ] ;
-
end ;
-
end ;
-
end ;
-
end ;
-
-
Bitmap . FreeImage ;
-
Bitmap . Assign (tmp ) ;
-
finally
-
f2 . Free ;
-
end ;
-
end ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
end ;
-
-
class function TRotateFilter . Description : String ;
-
begin
-
result : =TeeMsg_Rotate ;
-
end ;
-
-
procedure TRotateFilter . SetAngle ( const Value : Double ) ;
-
begin
-
if FAngle<>Value then
-
begin
-
FAngle : =Value ;
-
// Repaint;
-
end ;
-
end ;
-
-
procedure TRotateFilter . CreateEditor (Creator :IFormCreator ; AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddScroll ( 'Angle' , 0 , 360 ) ; // Do not localize
-
Creator . AddColor ( 'BackColor' ,TeeMsg_Back ) ; // Do not localize
-
Creator . AddCheckBox ( 'AutoSize' ,TeeMsg_Autosize ) ; // Do not localize
-
end ;
-
-
{ TMirrorFilter }
-
-
Constructor TMirrorFilter . Create (Collection : TCollection ) ;
-
begin
-
inherited ;
-
AllowRegion : = False ;
-
end ;
-
-
procedure TMirrorFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
-
var tmp : TBitmap ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
tmp : =TBitmap . Create ;
-
try
-
if (Direction =mdDown ) or (Direction =mdUp ) then
-
begin
-
TeeSetBitmapSize (tmp ,Bitmap . Width ,Bitmap . Height * 2 ) ;
-
-
if Direction =mdDown then
-
tmp . Canvas . Draw ( 0 , 0 ,Bitmap )
-
else
-
tmp . Canvas . Draw ( 0 ,Bitmap . Height ,Bitmap ) ;
-
-
TFlipFilter . ApplyTo (Bitmap ) ;
-
-
if Direction =mdDown then
-
tmp . Canvas . Draw ( 0 ,Bitmap . Height ,Bitmap )
-
else
-
tmp . Canvas . Draw ( 0 , 0 ,Bitmap ) ;
-
-
Bitmap . Height : =Bitmap . Height * 2 ;
-
end
-
else
-
begin
-
TeeSetBitmapSize (tmp ,Bitmap . Width * 2 ,Bitmap . Height ) ;
-
-
if Direction =mdRight then
-
tmp . Canvas . Draw ( 0 , 0 ,Bitmap )
-
else
-
tmp . Canvas . Draw (Bitmap . Width , 0 ,Bitmap ) ;
-
-
TReverseFilter . ApplyTo (Bitmap ) ;
-
-
if Direction =mdRight then
-
tmp . Canvas . Draw (Bitmap . Width , 0 ,Bitmap )
-
else
-
tmp . Canvas . Draw ( 0 , 0 ,Bitmap ) ;
-
-
Bitmap . Width : =Bitmap . Width * 2 ;
-
end ;
-
-
Bitmap . Canvas . Draw ( 0 , 0 ,tmp ) ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
-
procedure TMirrorFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddCombo ( 'Direction' ) ; // Do not localize
-
end ;
-
-
class function TMirrorFilter . Description : String ;
-
begin
-
result : =TeeMsg_Mirror ;
-
end ;
-
-
{ TTileFilter }
-
-
Constructor TTileFilter . Create (Collection : TCollection ) ;
-
begin
-
inherited ;
-
FNumCols : = 3 ;
-
FNumRows : = 3 ;
-
end ;
-
-
procedure TTileFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
-
var tmpCol ,
-
tmpRow ,
-
tmpW ,
-
tmpH : Integer ;
-
tmp : TBitmap ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
if FNumCols< 1 then FNumCols : = 1 ;
-
if FNumRows< 1 then FNumRows : = 1 ;
-
-
tmpW : = (R . Right -R . Left ) div FNumCols ;
-
tmpH : = (R . Bottom -R . Top ) div FNumRows ;
-
-
if (tmpW> 0 ) and (tmpH> 0 ) then
-
begin
-
tmp : =SmoothBitmap (Bitmap ,tmpW ,tmpH ) ;
-
try
-
for tmpCol : = 0 to FNumCols - 1 do
-
for tmpRow : = 0 to FNumRows - 1 do
-
Bitmap . Canvas . Draw (tmpCol *tmpW ,tmpRow *tmpH ,tmp ) ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
end ;
-
-
procedure TTileFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddInteger ( 'NumCols' ,TeeMsg_Columns , 1 , 1000 ) ; // Do not localize
-
Creator . AddInteger ( 'NumRows' ,TeeMsg_Rows , 1 , 1000 ) ; // Do not localize
-
end ;
-
-
class function TTileFilter . Description : String ;
-
begin
-
result : =TeeMsg_Tile ;
-
end ;
-
-
{ TBevelFilter }
-
-
Constructor TBevelFilter . Create (Collection : TCollection ) ;
-
begin
-
inherited ;
-
FBright : = 64 ;
-
FSize : = 15 ;
-
end ;
-
-
procedure TBevelFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
-
var t ,
-
x ,y ,
-
h2 ,w2 ,
-
x1 ,x2 ,
-
y1 ,y2 : Integer ;
-
begin
-
inherited ;
-
-
if Length (Lines ) = 0 then
-
Exit ;
-
-
x1 : =R . Left ;
-
x2 : =R . Right ;
-
y1 : =R . Top ;
-
y2 : =R . Bottom ;
-
-
w2 : = (R . Right -R . Left ) div 2 ;
-
h2 : = (R . Bottom -R . Top ) div 2 ;
-
-
for t : = 0 to FSize - 1 do
-
begin
-
if t<h2 then
-
for x : =R . Left +t to R . Right -t do
-
begin
-
with Lines [y1 ,x ] do
-
begin
-
if Red +Bright> 255 then Red : = 255
-
else Inc (Red ,Bright ) ;
-
if Green +Bright> 255 then Green : = 255
-
else Inc (Green ,Bright ) ;
-
if Blue +Bright> 255 then Blue : = 255
-
else Inc (Blue ,Bright ) ;
-
end ;
-
-
with Lines [y2 ,x ] do
-
begin
-
if Red -Bright< 0 then Red : = 0
-
else Dec (Red ,Bright ) ;
-
if Green -Bright< 0 then Green : = 0
-
else Dec (Green ,Bright ) ;
-
if Blue -Bright< 0 then Blue : = 0
-
else Dec (Blue ,Bright ) ;
-
end ;
-
-
end ;
-
-
Inc (y1 ) ;
-
Dec (y2 ) ;
-
-
if t<w2 then
-
for y : =R . Top +t + 1 to R . Bottom -t do
-
begin
-
with Lines [y ,x1 ] do
-
begin
-
if Red +Bright> 255 then Red : = 255
-
else Inc (Red ,Bright ) ;
-
if Green +Bright> 255 then Green : = 255
-
else Inc (Green ,Bright ) ;
-
if Blue +Bright> 255 then Blue : = 255
-
else Inc (Blue ,Bright ) ;
-
end ;
-
-
with Lines [y ,x2 ] do
-
begin
-
if Red -Bright< 0 then Red : = 0
-
else Dec (Red ,Bright ) ;
-
if Green -Bright< 0 then Green : = 0
-
else Dec (Green ,Bright ) ;
-
if Blue -Bright< 0 then Blue : = 0
-
else Dec (Blue ,Bright ) ;
-
end ;
-
end ;
-
-
Inc (x1 ) ;
-
Dec (x2 ) ;
-
end ;
-
end ;
-
-
procedure TBevelFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddScroll ( 'Bright' , 1 , 255 ) ; // Do not localize
-
Creator . AddScroll ( 'Size' , 1 , 1000 ) ; // Do not localize
-
end ;
-
-
class function TBevelFilter . Description : String ;
-
begin
-
result : =TeeMsg_Bevel ;
-
end ;
-
-
{ TZoomFilter }
-
-
Constructor TZoomFilter . Create (Collection : TCollection ) ;
-
begin
-
inherited ;
-
FPercent : = 10 ;
-
end ;
-
-
procedure TZoomFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
-
var w ,h ,
-
wp ,hp : Integer ;
-
-
procedure DoCrop (ALeft ,ATop : Integer ; ABitmap :TBitmap ) ;
-
begin
-
with TCropFilter . Create ( nil ) do
-
try
-
Left : =ALeft +wp ;
-
Top : =ATop +hp ;
-
Width : = Max ( 1 ,w - 2 *wp ) ;
-
Height : = Max ( 1 ,h - 2 *hp ) ;
-
Smooth : = Self . Smooth ;
-
Apply (ABitmap ,R ) ;
-
finally
-
Free ;
-
end ;
-
end ;
-
-
var tmp : TBitmap ;
-
begin
-
w : =R . Right -R . Left + 1 ;
-
h : =R . Bottom -R . Top + 1 ;
-
wp : = Round (FPercent *w * 0.005 ) ;
-
hp : = Round (FPercent *h * 0.005 ) ;
-
-
if (Bitmap . Width =w ) and (Bitmap . Height =h ) then
-
DoCrop (R . Left ,R . Top ,Bitmap )
-
else
-
begin
-
tmp : =TBitmap . Create ;
-
try
-
TeeSetBitmapSize (tmp ,w ,h ) ;
-
tmp . Canvas . CopyRect (TeeRect ( 0 , 0 ,w ,h ) ,Bitmap . Canvas ,R ) ;
-
-
DoCrop ( 0 , 0 ,tmp ) ;
-
-
Bitmap . Canvas . Draw (R . Left ,R . Top ,tmp ) ;
-
finally
-
tmp . Free ;
-
end ;
-
end ;
-
end ;
-
-
procedure TZoomFilter . CreateEditor (Creator : IFormCreator ;
-
AChanged : TNotifyEvent ) ;
-
begin
-
inherited ;
-
Creator . AddScroll ( 'Percent' , 0 , 100 ) ; // Do not localize
-
Creator . AddCheckBox ( 'Smooth' ,TeeMsg_Smooth ) ; // Do not localize
-
end ;
-
-
class function TZoomFilter . Description : String ;
-
begin
-
result : =TeeMsg_Zoom ;
-
end ;
-
-
procedure RotateGradient (Gradient :TCustomTeeGradient ; ABitmap :TBitmap ) ;
-
begin
-
with TRotateFilter . Create ( nil ) do
-
try
-
Angle : =Gradient . Angle ;
-
Apply (ABitmap ) ;
-
finally
-
Free ;
-
end ;
-
end ;
-
-
// This procedure will convert all pixels in ABitmap to levels of gray
-
Procedure TeeGrayScale (ABitmap :TBitmap ; Inverted : Boolean ; AMethod : Integer ) ;
-
var tmp : TGrayScaleFilter ;
-
begin
-
tmp : =TGrayScaleFilter . Create ( nil ) ;
-
try
-
if AMethod<> 0 then tmp . Method : =gmEye ;
-
tmp . Apply (ABitmap ) ;
-
finally
-
tmp . Free ;
-
end ;
-
-
if Inverted then
-
TInvertFilter . ApplyTo (ABitmap ) ;
-
end ;
-
-
initialization
-
TeeRegisterFilters ( [ TInvertFilter ,
-
TGrayScaleFilter ,
-
TMosaicFilter ,
-
TFlipFilter ,
-
TReverseFilter ,
-
TBrightnessFilter ,
-
TContrastFilter ,
-
TColorFilter ,
-
THueLumSatFilter ,
-
TBlurFilter ,
-
TSharpenFilter ,
-
TGammaCorrectionFilter ,
-
TEmbossFilter ,
-
TSoftenFilter ,
-
TCropFilter ,
-
TResizeFilter ,
-
TRotateFilter ,
-
TMirrorFilter ,
-
TTileFilter ,
-
TBevelFilter ,
-
TZoomFilter ] ) ;
-
-
TeeGradientRotate : =RotateGradient ;
-
finalization
-
TeeGradientRotate : = nil ;
-
FreeAndNil (FilterClasses ) ;
-
end .
-
-
tchart
最新推荐文章于 2019-08-01 04:06:19 发布