Mega Code Archive
Manipulate Bitmaps in a self contained static class
<![CDATA[
Title: Manipulate Bitmaps in a self contained static class
Question: Static class for TBitmap manipulation. No need to create class as it is STATIC. eg. Bitmaps.Grayscale(MyBitmap). Easy to use with JPG and other formats, simply convert to TBitmap, call class function and convert the TBitmap back to original format.
Answer:
unit MW_Bitmaps;
interface
{$REGION 'Documentation'}
// =================================================================================================
// UltraRAD Components
// Mike Heydon
//
// Bitmaps - Class of static bitmap functions. All calls are callable from
// the class itself and no instance of the class needs to be instantiated or
// freed. Attempting to create an instance of the class will generate runtime
// error.
//
// =================================================================================================
{$ENDREGION}
uses Windows, SysUtils, Graphics;
{$REGION 'Types and Classes'}
type
{Bitmaps Class}
Bitmaps = class(TObject)
strict private const
C_VERSION = '1.0.1';
strict private
class function IntToByte(AInteger : integer) : byte;
class function ColorToTriple(AColor : TColor) : TRGBTriple;
public
constructor Create;
class function Version : string;
class procedure Blur(ABitmap : TBitmap);
class procedure ChangeRGB(ABitmap : TBitmap;
AIncRed,AIncGreen,AIncBlue : byte);
class procedure ColorNoise(ABitmap : TBitmap; AAmount : integer = 100);
class procedure Contrast(ABitmap : TBitmap; APercent : integer = 50);
class procedure Darken(ABitmap : TBitmap; APercent : integer = 50);
class procedure Emboss(ABitmap : TBitmap; ADepth : byte = 1);
class procedure Flaxen(ABitmap : TBitmap);
class procedure FlipHorizontal(ABitmap : TBitmap);
class procedure FlipVertical(ABitmap : TBitmap);
class procedure GrayScale(ABitmap : TBitmap);
class procedure Lighten(ABitmap : TBitmap; APercent : byte = 50);
class procedure MonoNegative(ABitmap : TBitmap);
class procedure MonoNoise(ABitmap : TBitmap; AAmount : integer = 100);
class procedure Mosaic(ABitmap : TBitmap; ASize : integer = 5);
class procedure Negative(ABitmap : TBitmap);
class procedure Posterize(ABitmap: TBitmap; AAmount : integer = 255);
class procedure Saturation(ABitmap : TBitmap; APercent : integer = 90);
class procedure Sepia(ABitmap : TBitmap; APercentDark : byte = 90);
class procedure Twotone(ABitmap : TBitmap ; const ALightColor,
ADarkColor : TColor; APercent : integer = 50);
end;
{$ENDREGION}
// -------------------------------------------------------------------------------------------------
implementation
{$REGION 'Bitmaps Class'}
// =============================================================================
// Generate a runtime error if an attempt is made to create an instance
// of the class
// =============================================================================
constructor Bitmaps.Create;
begin
raise Exception.Create('Bitmaps.Create - Cannot create an instance, ' +
'class contains static functions only. ' +
'Usage Example : Bitmaps.Grayscale(MyBitmap)');
end;
// =============================================================================
// Retrieve the class version as defined by C_VERSION
// =============================================================================
class function Bitmaps.Version : string;
begin
Result := C_VERSION;
end;
class function Bitmaps.IntToByte(AInteger : integer) : byte;
var iResult : byte;
begin
if AInteger 255 then
iResult := 255
else
if AInteger 0 then
iResult := 0
else
iResult := AInteger;
Result := iResult;
end;
class function Bitmaps.ColorToTriple(AColor : TColor) : TRGBTriple;
type
TRGBStruc = record
case TColor of
1 : (ColorValue: TColor);
2 : (Bytes: array [0..3] of Byte);
end;
var rCol : TRGBStruc;
begin
rCol.ColorValue := AColor;
Result.rgbtRed := rCol.Bytes[0];
Result.rgbtGreen := rCol.Bytes[1];
Result.rgbtBlue := rCol.Bytes[2];
end ;
// =============================================================================
// Change RGB to New in Bitmap
// Increment or Decrememt the RGB colors by values.
// =============================================================================
class procedure Bitmaps.ChangeRGB(ABitmap : TBitmap;
AIncRed,AIncGreen,AIncBlue : byte);
var iCol,iRow : integer;
pRow : ^TRGBTriple;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pRow := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width -1 do begin
pRow^.rgbtBlue := self.IntToByte(AIncBlue + pRow^.rgbtBlue);
pRow^.rgbtGreen := self.IntToByte(AIncGreen + pRow^.rgbtGreen);
pRow^.rgbtRed := self.IntToByte(AIncRed + pRow^.rgbtRed);
inc(pRow);
end;
end;
end;
// =============================================================================
// Flaxen the Bitmap
// =============================================================================
class procedure Bitmaps.Flaxen(ABitmap : TBitmap);
var iCol,iRow : integer;
pWsk1,pWsk2,pWsk3 : ^TRGBTriple;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk1 := ABitmap.ScanLine[iRow];
pWsk2 := pWsk1;
pWsk3 := pWsk1;
inc(pWsk2);
inc(pWsk3,2);
for iCol := 0 to ABitmap.Width - 1 do begin
pWsk1^.rgbtRed := (pWsk1^.rgbtRed + pWsk2^.rgbtGreen +
pWsk3^.rgbtBlue) div 3;
pWsk2^.rgbtGreen := (pWsk1^.rgbtGreen + pWsk2^.rgbtGreen +
pWsk3^.rgbtBlue) div 3;
pWsk2^.rgbtBlue := (pWsk1^.rgbtBlue + pWsk2^.rgbtGreen +
pWsk3^.rgbtBlue) div 3;
inc(pWsk1);
inc(pWsk2);
inc(pWsk3);
end;
end;
end;
// =============================================================================
// Add Colored Noise Speckle
// =============================================================================
class procedure Bitmaps.ColorNoise(ABitmap : TBitmap; AAmount : integer = 100);
var pWsk : ^byte;
iCol,iRow : integer;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width * 3 - 1 do begin
pWsk^ := self.IntToByte(pWsk^ + (Random(AAmount) - (AAmount shr 1)));
inc(pWsk);
end;
end;
end;
// =============================================================================
// Change to Gray Scale
// =============================================================================
class procedure Bitmaps.GrayScale(ABitmap : TBitmap);
var pRow : ^TRGBTriple;
iCol,iRow,iIndex : integer;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pRow := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width - 1 do begin
iIndex := ((pRow^.rgbtRed * 77 + pRow^.rgbtGreen * 150 +
pRow^.rgbtBlue * 29) shr 8);
pRow^.rgbtBlue := iIndex;
pRow^.rgbtGreen := iIndex;
pRow^.rgbtRed := iIndex;
inc(pRow);
end;
end;
end;
// =============================================================================
// Change Bitmap to Sepia
// =============================================================================
class procedure Bitmaps.Sepia(ABitmap : TBitmap; APercentDark : byte = 90);
var iDepth : byte;
pRow : ^TRGBTriple;
iCol,iRow : Integer;
begin
if APercentDark = 100 then
iDepth := 0
else
iDepth := 255 - trunc((APercentDark / 100.0) * 255.0);
ABitmap.PixelFormat:=pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pRow := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width -1 do begin
pRow^.rgbtBlue :=(pRow^.rgbtBlue + pRow^.rgbtGreen + pRow^.rgbtRed) div 3;
pRow^.rgbtGreen := pRow^.rgbtBlue;
pRow^.rgbtRed := pRow^.rgbtBlue;
inc(pRow^.rgbtRed,iDepth * 2);
inc(pRow^.rgbtGreen,iDepth);
if pRow^.rgbtRed (iDepth * 2) then pRow^.rgbtRed := 255;
if pRow^.rgbtGreen iDepth then pRow^.rgbtGreen := 255;
inc(pRow);
end;
end;
end;
// =============================================================================
// Posterize a Bitmap
// =============================================================================
class procedure Bitmaps.Posterize(ABitmap: TBitmap; AAmount: integer = 255);
var iCol,iRow : integer;
pWsk : ^byte;
begin
ABitmap.PixelFormat := pf24bit;
if AAmount 0 then AAmount := 1;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.Scanline[iRow];
for iCol := 0 to ABitmap.Width * 3 - 1 do begin
pWsk^ := self.IntToByte(round(pWsk^ / AAmount) * AAmount);
inc(pWsk);
end;
end;
end;
// =============================================================================
// Emboss a Bitmap
// =============================================================================
class procedure Bitmaps.Emboss(ABitmap : TBitmap; ADepth : byte = 1);
var x, y, i : integer;
p1, p2: PByteArray;
begin
if ADepth 10 then aDepth := 10;
if ADepth = 0 then ADepth := 1;
ABitmap.PixelFormat := pf24bit;
for i := 0 to ADepth do begin
for y := 0 to ABitmap.Height - 2 do begin
p1 := ABitmap.ScanLine[y];
p2 := ABitmap.ScanLine[y+1];
for x := 0 to ABitmap.Width do begin
p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] xor $FF)) shr 1;
p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
p1[x * 3 + 2] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
end;
end;
end;
end;
// =============================================================================
// Add Mono Noise to Bitmap
// =============================================================================
class procedure Bitmaps.MonoNoise(ABitmap : TBitmap; AAmount: integer = 100);
var pRow : ^TRGBTriple;
iCol,iRow,iNoise : integer;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pRow := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width - 1 do begin
iNoise := Random(AAmount) - (AAmount shr 1);
pRow^.rgbtBlue :=self.IntToByte(pRow^.rgbtBlue + iNoise);
pRow^.rgbtGreen :=self.IntToByte(pRow^.rgbtGreen + iNoise);
pRow^.rgbtRed :=self.IntToByte(pRow^.rgbtRed + iNoise);
inc(pRow);
end;
end;
end;
// =============================================================================
// Blur a Bitmap
// =============================================================================
class procedure Bitmaps.Blur(ABitmap : TBitmap);
var pTL,pTC,pTR,pBL,
pBC,pBR,pLL,pLC,pLR : ^TRGBTriple;
iCol,iRow : integer;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 1 to ABitmap.Height - 2 do begin
pTL := ABitmap.ScanLine[iRow - 1];
pTC := pTL;
pTR := pTL;
pBL := ABitmap.ScanLine[iRow];
pBC := pBL;
pBR := pBL;
pLL := ABitmap.ScanLine[iRow + 1];
pLC := pLL;
pLR := pLL;
inc(pTC);
inc(pTR,2);
inc(pBC);
inc(pBR,2);
inc(pLC);
inc(pLR,2);
for iCol := 1 to (ABitmap.Width - 2) do begin
pBC^.rgbtRed:= (pBC^.rgbtRed + pBL^.rgbtRed + pBR^.rgbtRed +
pTC^.rgbtRed + pTL^.rgbtRed + pTR^.rgbtRed +
pLL^.rgbtRed + pLC^.rgbtRed + pLR^.rgbtRed) div 9 ;
pBC^.rgbtGreen:=(pBC^.rgbtGreen + pBL^.rgbtGreen + pBR^.rgbtGreen +
pTC^.rgbtGreen + pTL^.rgbtGreen + pTR^.rgbtGreen +
pLL^.rgbtGreen + pLC^.rgbtGreen + pLR^.rgbtGreen) div 9 ;
pBC^.rgbtBlue:=(pBC^.rgbtBlue + pBL^.rgbtBlue + pBR^.rgbtBlue +
pTC^.rgbtBlue + pTL^.rgbtBlue + pTR^.rgbtBlue +
pLL^.rgbtBlue + pLC^.rgbtBlue + pLR^.rgbtBlue ) div 9 ;
inc(pTL);
inc(pTC);
inc(pTR);
inc(pBL);
inc(pBC);
inc(pBR);
inc(pLL);
inc(pLC);
inc(pLR);
end;
end;
end;
// =============================================================================
// Mosaic
// =============================================================================
class procedure Bitmaps.Mosaic(ABitmap : TBitmap ; ASize : integer = 5);
var x,y,i,j : integer;
p1,p2 : pByteArray;
r,g,b : byte;
begin
if ASize 20 then ASize := 20;
if ASize 2 then ASize := 2;
ABitmap.PixelFormat := pf24bit;
y := 0;
repeat
p1:= ABitMap.Scanline[y];
repeat
j := 1;
repeat
p2 := ABitMap.Scanline[y];
x := 0;
repeat
r := p1[x * 3];
g := p1[x * 3 + 1];
b := p1[x * 3 + 2];
i :=1;
repeat
p2[x * 3]:=r;
p2[x * 3 + 1] := g;
p2[x * 3 + 2] := b;
inc(x);
inc(i);
until (x = ABitMap.Width) or (i ASize);
until x = ABitMap.Width;
inc(j);
inc(y);
until (y = ABitMap.Height) or (j ASize);
until (y = ABitMap.Height) or (x = ABitMap.Width);
until y = ABitMap.Height;
end;
// =============================================================================
// Lighten Bitmap
// =============================================================================
class procedure Bitmaps.Lighten(ABitmap : TBitmap; APercent : byte = 50);
var pWsk : ^byte;
iCol,iRow,iAmount : integer;
begin
if APercent = 100 then
iAmount := 255
else
iAmount := trunc((APercent / 100.0) * 255);
ABitmap.PixelFormat := Graphics.pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width * 3 - 1 do begin
pWsk^ := self.IntToByte(pWsk^ + ((255 - pWsk^) * iAmount) div 255);
inc(pWsk);
end;
end;
end;
// =============================================================================
// Darken Bitmap
// =============================================================================
class procedure Bitmaps.Darken(ABitmap : TBitmap; APercent : integer = 50);
var pWsk : ^byte;
iCol,iRow,iAmount : integer;
begin
if APercent = 100 then
iAmount := 255
else
iAmount := trunc((APercent / 100.0) * 255);
ABitmap.Pixelformat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width * 3 - 1 do begin
pWsk^ := self.IntToByte(pWsk^ - (pWsk^ * iAmount) div 255);
inc(pWsk);
end;
end;
end;
// =============================================================================
// Twotone a bitmap into Light and Dark with Threshold Percent
// =============================================================================
class procedure Bitmaps.Twotone(ABitmap : TBitmap ; const ALightColor,
ADarkColor : TColor; APercent : integer = 50);
var pRow : ^TRGBTriple;
rLight,rDark : TRGBTriple;
iCol,iRow,iIndex,iAmount : integer;
begin
rLight := self.ColorToTriple(ALightColor);
rDark := self.ColorToTriple(ADarkColor);
if APercent = 100 then
iAmount := 255
else
iAmount := trunc((APercent / 100.0) * 255);
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pRow := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width -1 do begin
iIndex := ((pRow^.rgbtRed * 77 + pRow^.rgbtGreen * 150 +
pRow^.rgbtBlue * 29) shr 8);
if iIndex iAmount then
pRow^ := rLight
else
pRow^ := rDark;
inc(pRow);
end;
end;
end;
// =============================================================================
// Negative of a Bitmap
// =============================================================================
class procedure Bitmaps.Negative(ABitmap : TBitmap);
var iCol,iRow : integer;
pWsk : ^byte;
begin
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to (ABitmap.Width * 3) - 1 do begin
pWsk^ := not pWsk^;
inc(pWsk);
end;
end;
end;
class procedure Bitmaps.MonoNegative(ABitmap : TBitmap);
begin
self.GrayScale(ABitMap);
self.Negative(ABitMap);
end;
// =============================================================================
// Saturation
// =============================================================================
class procedure Bitmaps.Saturation(ABitmap : TBitmap; APercent : integer = 90);
var pWsk : ^TRGBTriple;
iGray,iCol,iRow,iAmount : integer;
begin
ABitmap.PixelFormat := pf24bit;
if APercent = 100 then
iAmount := 255
else
iAmount := trunc((APercent / 100.0) * 255);
for iRow := 0 to ABitmap.Height-1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width - 1 do begin
iGray := (pWsk^.rgbtBlue + pWsk^.rgbtGreen + pWsk^.rgbtRed) div 3;
pWsk^.rgbtRed := self.IntToByte(iGray + (((pWsk^.rgbtRed - iGray) *
iAmount) div 255));
pWsk^.rgbtGreen := self.IntToByte(iGray + (((pWsk^.rgbtGreen - iGray) *
iAmount) div 255));
pWsk^.rgbtBlue := self.IntToByte(iGray + (((pWsk^.rgbtBlue - iGray) *
iAmount) div 255));
inc(pWsk);
end;
end;
end;
// =============================================================================
// Change contrast of Bitmap
// =============================================================================
class procedure Bitmaps.Contrast(ABitmap : TBitmap; APercent : integer = 50);
var pWsk : ^byte;
iCol,iRow,iAmount : integer;
begin
if APercent = 100 then
iAmount := 255
else
iAmount := trunc((APercent / 100.0) * 255);
ABitmap.PixelFormat := pf24bit;
for iRow := 0 to ABitmap.Height - 1 do begin
pWsk := ABitmap.ScanLine[iRow];
for iCol := 0 to ABitmap.Width * 3 -1 do begin
if pWsk^ 127 then
pWsk^ := self.IntToByte(pWsk^ + (abs(127 - pWsk^) * iAmount) div 255)
else
pWsk^ := self.IntToByte(pWsk^ - (abs(127 - pWsk^) * iAmount) div 255);
inc(pWsk);
end;
end;
end;
// =============================================================================
// Flip Horizontal
// =============================================================================
class procedure Bitmaps.FlipHorizontal(ABitmap : TBitmap);
type TByteTriple = array [0..2] of byte;
var pByteL,pByteR : ^TByteTriple;
aByteTemp : TByteTriple;
iCol,iRow : integer;
begin
ABitmap.PixelFormat:=pf24bit;
for iRow :=0 to ABitmap.Height - 1 do begin
pByteL := ABitmap.ScanLine[iRow];
pByteR := ABitmap.ScanLine[iRow];
inc(pByteR,ABitmap.Width - 1);
for iCol := 0 to (ABitmap.Width -1) div 2 do begin
aByteTemp := pByteL^;
pByteL^ := pByteR^;
pByteR^ := aByteTemp;
inc(pByteL);
dec(pByteR);
end;
end;
end;
// =============================================================================
// Flip Vertical
// =============================================================================
class procedure Bitmaps.FlipVertical(ABitmap : TBitmap);
var pByteTop,pByteBottom : ^byte;
iByteTemp : byte;
iCol,iRow : integer;
begin
ABitmap.PixelFormat:=pf24bit;
for iRow := 0 to (ABitmap.Height - 1) div 2 do begin
pByteTop := ABitmap.ScanLine[iRow];
pByteBottom := ABitmap.ScanLine[ABitmap.Height - 1 - iRow];
for iCol :=0 to ABitmap.Width * 3 - 1 do begin
iByteTemp := pByteTop^;
pByteTop^ := pByteBottom^;
pByteBottom^ := iByteTemp;
inc(pByteTop);
inc(pByteBottom);
end;
end;
end;
{$ENDREGION}
end.
]]>