📄 pseffect.pas
字号:
(Name: 'Reveal diagonal from top left'; Proc: Effect110),
(Name: 'Reveal diagonal from top right'; Proc: Effect111),
(Name: 'Reveal diagonal from bottom left'; Proc: Effect112),
(Name: 'Reveal diagonal from bottom right'; Proc: Effect113),
(Name: 'Diagonal sweep from top left bottom right anticlockwise'; Proc: Effect114),
(Name: 'Diagonal sweep from top left bottom right clockwise'; Proc: Effect115),
(Name: 'Starburst clockwise from center'; Proc: Effect116),
(Name: 'Triangular shred'; Proc: Effect117),
(Name: 'Fade'; Proc: Effect118),
(Name: 'Pivot from top left'; Proc: Effect119),
(Name: 'Pivot from bottom left'; Proc: Effect120),
(Name: 'Pivot from top right'; Proc: Effect121),
(Name: 'Pivot from bottom right'; Proc: Effect122),
(Name: 'Speckle appear from right'; Proc: Effect123),
(Name: 'Speckle appear from left'; Proc: Effect124),
(Name: 'Speckle appear from bottom'; Proc: Effect125),
(Name: 'Speckle appear from top'; Proc: Effect126),
(Name: 'Random squares appear'; Proc: Effect127),
(Name: 'Push right'; Proc: Effect128),
(Name: 'Push left'; Proc: Effect129),
(Name: 'Push and squeeze right'; Proc: Effect130),
(Name: 'Push and squeeze left'; Proc: Effect131),
(Name: 'Push down'; Proc: Effect132),
(Name: 'Push up'; Proc: Effect133),
(Name: 'Push and sqeeze down'; Proc: Effect134),
(Name: 'Push and sqeeze up'; Proc: Effect135),
(Name: 'Blind vertically'; Proc: Effect136),
(Name: 'Blind horizontally'; Proc: Effect137),
(Name: 'Uneven blind from left'; Proc: Effect138),
(Name: 'Uneven blind from right'; Proc: Effect139),
(Name: 'Uneven blind from top'; Proc: Effect140),
(Name: 'Uneven blind from bottom'; Proc: Effect141),
(Name: 'Rectangular shred'; Proc: Effect142),
(Name: 'Sweep clockwise'; Proc: Effect143),
(Name: 'Sweep anticlockwise'; Proc: Effect144),
(Name: 'Rectangles apear from left and disapear to right'; Proc: Effect145),
(Name: 'Rectangles apear from right and disapear to left'; Proc: Effect146),
(Name: 'Rectangles apear from up and disapear to bottom'; Proc: Effect147),
(Name: 'Rectangles apear from bottom and disapear to up'; Proc: Effect148),
(Name: 'Rotational rectangle in center'; Proc: Effect149),
(Name: 'Rotational star in center'; Proc: Effect150),
(Name: 'Spiral rectangle'; Proc: Effect151),
(Name: 'Circular shred'; Proc: Effect152),
(Name: 'Reveal V from left'; Proc: Effect153),
(Name: 'Reveal V from right'; Proc: Effect154),
(Name: 'Reveal V from top'; Proc: Effect155),
(Name: 'Reveal V from bottom'; Proc: Effect156),
(Name: 'Bow Tie Horizontal'; Proc: Effect157),
(Name: 'Bow Tie Vertical'; Proc: Effect158),
(Name: 'Diagonal Cross In'; Proc: Effect159),
(Name: 'Diagonal Cross Out'; Proc: Effect160),
(Name: 'Starburst anticlockwise from center'; Proc: Effect161),
(Name: 'Zigzag Horizontal'; Proc: Effect162),
(Name: 'Zigzag Vertical'; Proc: Effect163),
(Name: 'Diamond shred'; Proc: Effect164),
(Name: 'Reveal diamond out from centre'; Proc: Effect165),
(Name: 'Reveal diamond in to centre'; Proc: Effect166),
(Name: 'Diagonal Box Out'; Proc: Effect167),
(Name: 'Pixelate'; Proc: Effect168),
(Name: 'Dissolve'; Proc: Effect169),
(Name: 'Random Bars Horizontal'; Proc: Effect170),
(Name: 'Random Bars Vertical'; Proc: Effect171));
type
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = array[0..0] of TRGBQuad;
type
{$IFNDEF DELPHI4_UP}
HRGN = THandle;
{$ENDIF}
TComplexRegion = class(TObject)
private
RgnData: PRgnData;
Capacity: Integer;
Count: Integer;
Bounds: TRect;
Rect: PRect;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure AddRect(Left, Top, Right, Bottom: Integer);
function CreateRegion: HRGN;
end;
// In the following functions, all the bitmap objects should be 32bit bitmap format.
procedure ApplyHReflect(Bitmap: TBitmap; Amount: Byte; Pos, Size: Integer);
procedure ApplyVReflect(Bitmap: TBitmap; Amount: Byte; Pos, Size: Integer);
procedure MergeTransparent(dstBitmap, srcBitmap: TBitmap; Transparency: Integer; X, Y, Width, Height: Integer);
procedure MergeRotate(dstBitmap, srcBitmap: TBitmap; xOrg, yOrg: Integer; Angle {radians}: Extended);
procedure RotatePoints(var Points: array of TPoint; xOrg, yOrg: Integer; Angle {radians}: Extended);
implementation
uses
Math {$IFDEF DELPHI6_UP}, Types {$ENDIF};
{ TComplexRegion }
constructor TComplexRegion.Create;
begin
Clear;
end;
destructor TComplexRegion.Destroy;
begin
ReallocMem(RgnData, 0);
inherited Destroy;
end;
procedure TComplexRegion.Clear;
begin
ReallocMem(RgnData, 0);
Count := 0;
Capacity := 0;
with Bounds do
begin
Left := +MaxInt;
Top := +MaxInt;
Right := -MaxInt;
Bottom := -MaxInt;
end;
end;
procedure TComplexRegion.AddRect(Left, Top, Right, Bottom: Integer);
begin
if Count = Capacity then
begin
Inc(Capacity, 500);
ReallocMem(RgnData, SizeOf(TRgnData) + Capacity * SizeOf(TRect));
Rect := PRect(@(RgnData^.Buffer));
Inc(Rect, Count);
end;
Rect^.Left := Left;
Rect^.Top := Top;
Rect^.Right := Right;
Rect^.Bottom := Bottom;
Inc(Rect);
Inc(Count);
if Bounds.Left > Left then
Bounds.Left := Left;
if Bounds.Top > Top then
Bounds.Top := Top;
if Bounds.Right < Right then
Bounds.Right := Right;
if Bounds.Bottom < Bottom then
Bounds.Bottom := Bottom;
end;
function TComplexRegion.CreateRegion: HRGN;
begin
if Assigned(RgnData) then
begin
with RgnData^.rdh do
begin
dwSize := SizeOf(TRgnDataHeader);
iType := RDH_RECTANGLES;
nCount := Count;
nRgnSize := SizeOf(TRect);
rcBound := Bounds;
end;
Result := ExtCreateRegion(nil, SizeOf(TRgnData) + Count * SizeOf(TRect), RgnData^);
end
else
Result := 0;
end;
{ Global Functions }
procedure ApplyHReflect(Bitmap: TBitmap; Amount: Byte; Pos, Size: Integer);
var
Pixels: PRGBQuad;
bmpWidth, bmpHeight: Integer;
Middle, JumpCount, X, Y, T, S, J: Integer;
PreCalcDelta: PInteger;
Delta: PInteger;
begin
if (Size < 2) or (Amount = 0) then Exit;
bmpWidth := Bitmap.Width;
bmpHeight := Bitmap.Height;
Pixels := Bitmap.ScanLine[bmpHeight - 1];
Middle := Size div 2;
JumpCount := bmpWidth - (Pos + Size);
GetMem(PreCalcDelta, SizeOf(Integer) * Size);
try
Delta := PreCalcDelta;
T := -Amount;
if Middle < Amount then
begin
S := Amount div Middle;
for X := 1 to Size do
begin
Delta^ := T;
Inc(Delta);
Inc(T, S);
if X = Middle then
S := -S;
end;
end
else
begin
S := Middle div Amount;
J := S;
for X := 1 to Size do
begin
Delta^ := T;
Inc(Delta);
if X = J then
begin
Inc(J, S);
if X < Middle then
Inc(T)
else
Dec(T);
end;
end;
end;
for Y := 0 to Bitmap.Height - 1 do
begin
Delta := PreCalcDelta;
Inc(Pixels, Pos);
for X := 1 to Size do
begin
with Pixels^ do
begin
T := rgbRed + Delta^;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbRed := T;
T := rgbGreen + Delta^;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbGreen := T;
T := rgbBlue + Delta^;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbBlue := T;
end;
Inc(Pixels);
Inc(Delta);
end;
Inc(Pixels, JumpCount);
end;
finally
FreeMem(PreCalcDelta);
end;
end;
procedure ApplyVReflect(Bitmap: TBitmap; Amount: Byte; Pos, Size: Integer);
var
Pixels: PRGBQuad;
Middle, Step, Jump, Delta: Integer;
X, Y, T, J: Integer;
begin
if (Size < 2) or (Amount = 0) then Exit;
Pixels := Bitmap.ScanLine[Pos + Size - 1];
Middle := Size div 2;
if Middle < Amount then
begin
Jump := 1;
Step := Amount div Middle;
end
else
begin
Jump := Middle div Amount;
Step := 1;
end;
J := Jump;
Delta := -Amount;
for Y := 1 to Size do
begin
for X := 0 to Bitmap.Width - 1 do
begin
with Pixels^ do
begin
T := rgbRed + Delta;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbRed := T;
T := rgbGreen + Delta;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbGreen := T;
T := rgbBlue + Delta;
if T < 0 then
T := 0
else if T > 255 then
T := 255;
rgbBlue := T;
end;
Inc(Pixels);
end;
if Y = J then
begin
if Y < Middle then
Inc(Delta, Step)
else
Dec(Delta, Step);
Inc(J, Jump);
end;
end;
end;
procedure MergeTransparent(dstBitmap, srcBitmap: TBitmap; Transparency: Integer;
X, Y, Width, Height: Integer);
var
dstPixel, srcPixel: PRGBQuad;
JumpCount, Weight: Integer;
R, C: Integer;
begin
JumpCount := srcBitmap.Width - (X + Width);
srcPixel := srcBitmap.ScanLine[Y + Height - 1];
dstPixel := dstBitmap.ScanLine[Y + Height - 1];
Weight := MulDiv(256, Transparency, 100);
for R := 0 to Height - 1 do
begin
Inc(srcPixel, X);
Inc(dstPixel, X);
for C := 0 to Width - 1 do
begin
with dstPixel^ do
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -