» Delphi code part 4 - Bitmap - Blog Archive

Delphi code part 4 - Bitmap

March 7th, 2007 by William Yang

After I learned how colour can be manupilated, I started to work on bitmaps. Back then I even borrowed a book to learn how bitmaps can be modified, like blur, sharp, find edge, etc. The technique was called filtering.

Here is the code

Show Code | Download Grafman.pas

{ ---------------------------------------------------
Graphics Manager
Copyright (r) by E-Port Software Team
Version : 4.0 Author : William Yang
Last Update 1 - Oct - 98
--------------------------------------------------- }
unit GrafMan;
interface
uses Windows, SysUtils, Graphics, Classes, ColorMan, ExtCtrls, Forms,
Drawman, NumMan;
{ *************************************************************************
There is a small bug in this unit.
Becase I used a internal variable for each function that returns
a TBitmap object, which means if you are going to add another function
you must not cross use this variable.
I mean you cannot use in one of the function and not yet wait until it is finished
call another function in this unit.
_________________________________________________________________________ }
type
EBitmapOperationError = Exception;
TGraphicFilter = array[0..2, 0..2] of Integer;
procedure ColoriseImage(Bmp : TBitmap; BaseColor : TColor);
procedure MergeBMP(Pic1, Pic2 : TBitmap);
procedure SoftenBMP(Src : TBitmap);
procedure GreyBMP(Src : TBitmap);
procedure BWOnlyBMP(Src : TBitmap);
procedure DarkenBMP(Bmp : TBitmap; Grade : Integer);
procedure BrightenBMP(Bmp : TBitmap; Grade : Integer);
procedure MergeBMPExt(Pic1, Pic2 : TBitmap; Grade: Byte);
function BMPFromRes(ResName: String) : TBitmap;
function ResizeBMP(Src: TBitmap; Width, Height: Integer): TBitmap;
function LoadBMPFile(Filename: String): TBitmap;
function DisabledBmp(Src: TBitmap; DisabledColor, FaceColor: TColor): TBitmap;
function CreatePattern(Color1, Color2: TColor ): TBitmap;
function BmpToLCD(Src: TBitmap; ForeColor, Backcolor: TColor): TBitmap;
procedure BevelBmp(Src: TBitmap; Size: Integer);
procedure DownButton(Src: TBitmap; Bevel: Integer);
procedure UpButton(Src: TBitmap; Bevel: Integer);
procedure ApplyFilter(Src: TBitmap; GF: TGraphicFilter);
const
BlurFilter : TGraphicFilter = ( (5, 15, 5),
(15, 20, 15),
(5, 15, 5));
SharpFilter : TGraphicFilter = ((0, -100, 0),
(-100, 500, -100),
(0, -100, 0));
EdgeFilter : TGraphicFilter = ((0, -100, 0),
(-100, 400, -100),
(0, -100, 0));
EmbossFilter : TGraphicFilter = ((-100, 0, 0),
(0, 0, 0),
(0, 0, 100));
Enhance3DFilter : TGraphicFilter = ((-100, 5, 5),
(5, 5, 5),
(5, 5, 100));
var
Calcs: Integer;
implementation
var
TmpMem : TBitmap;
function RollRGB(R, G, B: Real): TColor;
begin
Result := RGB(Abs(Round(R) mod 255), Abs(Round(G) mod 255), Abs(Round(B) mod 255));
end;
procedure ApplyFilter(Src: TBitmap; GF: TGraphicFilter);
var
i, j: Integer;
x, y: Integer;
r, g, b: Integer;
p: PRGBArray;
Red, Green, Blue: Integer;
begin
TmpMem.Width := Src.Width;
TmpMem.Height := Src.Height;
TmpMem.Canvas.Draw(0, 0, Src);
TmpMem.PixelFormat := pf24Bit;
Calcs := 0;
for y := 0 to Src.Height-1 do
begin
p := Src.Scanline[y];
for x := 0 to Src.Width-1 do
begin
Red := 0; Green := 0; Blue := 0;
for i := 0 to 2 do
for j := 0 to 2 do
begin
if Between((x+i-1), 0, Src.Width-1) and Between((y+j-1), 0, Src.Height-1) then
begin
Decolor(RGBToInt(PRGBArray(TmpMem.Scanline[y+j-1])[x+i-1]), r, g, b);
Red := Red + GF[i, j]*R;
Blue := Blue + GF[i, j]*B;
Green := Green + GF[i, j]*G;
Inc(Calcs, 3);
end;
end;
p[x] := IntToRGB(ERGB(Red/100, Green/100, Blue/100));
end;
end;
TmpMem.Width := 1;
TmpMem.Height := 1;
end;
procedure DownButton(Src: TBitmap; Bevel: Integer);
var
i, j : Integer;
p: PRGBArray;
begin
if Bevel <= 0 then Bevel := 1;
if Src.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Src.Height-1 do
begin
P := Src.Scanline[i];
for j := 0 to Bevel-1 do
begin
P[j] := IntToRGB(DarkenColor(RGBToInt(P[j]), Round(100-(j)/Bevel*100)));
P[Src.Width-j-1] := IntToRGB(BrightenColor(RGBToInt(P[Src.Width-j-1]), Round(100-(j)/Bevel*100)));
end;
for j := 0 to Src.Width-1 do
begin
if Between(i, 0, Bevel-1) then
P[j] := IntToRGB(DarkenColor(RGBToInt(P[j]), Round(100-(i)/Bevel*100)));
if Between(i, Src.Height-Bevel-1, Src.Height-1) then
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Round(100-((Src.Height-i-1))/Bevel*100)));
end;
end;
end;
procedure UpButton(Src: TBitmap; Bevel: Integer);
var
i, j : Integer;
p: PRGBArray;
begin
if Bevel <= 0 then Bevel := 1;
if Src.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Src.Height-1 do
begin
P := Src.Scanline[i];
for j := 0 to Bevel-1 do
begin
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Round(100-(j)/Bevel*100)));
P[Src.Width-j-1] := IntToRGB(DarkenColor(RGBToInt(P[Src.Width-j-1]), Round(100-(j)/Bevel*100)));
end;
for j := 0 to Src.Width-1 do
begin
if Between(i, 0, Bevel-1) then
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Round(100-(i)/Bevel*100)));
if Between(i, Src.Height-Bevel-1, Src.Height-1) then
P[j] := IntToRGB(DarkenColor(RGBToInt(P[j]), Round(100-((Src.Height-i-1))/Bevel*100)));
end;
end;
end;
procedure BevelBmp(Src: TBitmap; Size: Integer);
var
i, j : Integer;
p: PRGBArray;
begin
if Size <= 0 then Size := 1;
if Src.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Src.Height-1 do
begin
P := Src.Scanline[i];
for j := 0 to Size-1 do
begin
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Round(100-(j+1)/Size*100)));
P[Src.Width-j-1] := IntToRGB(DarkenColor(RGBToInt(P[Src.Width-j-1]), Round(100-(j+1)/Size*100)));
end;
for j := 0 to Src.Width-1 do
begin
if Between(i, -1, Size) then
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Round(100-(i+1)/Size*100)));
if Between(i, Src.Height-Size-1, Src.Height) then
P[j] := IntToRGB(DarkenColor(RGBToInt(P[j]), Round(100-((Src.Height-i)+1)/Size*100)));
end;
end;
end;
function CreatePattern(Color1, Color2: TColor ): TBitmap;
var
X, Y: Integer;
begin
TmpMem.Width := 8;
TmpMem.Height := 8;
with TmpMem.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := Color1;
FillRect(Rect(0, 0, TmpMem.Width, TmpMem.Height));
for Y := 0 to 7 do
for X := 0 to 7 do
if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
Pixels[X, Y] := Color2; { on even/odd rows }
end;
Result := TmpMem;
end;
function BmpToLCD(Src: TBitmap; ForeColor, Backcolor: TColor): TBitmap;
var
x, y: Integer;
begin
TmpMem.Width := Src.Width*4;
TmpMem.Height := Src.Height*4;
with TmpMem.Canvas do
begin
Brush.Color := BackColor;
Brush.Style := bsSolid;
FillRect(Rect(0, 0, TmpMem.Width, TmpMem.Height));
Brush.Color := ForeColor;
Pen.Color := MergeColor(ForeColor, BackColor);
for x := 0 to Src.Width do
for y := 0 to Src.Height do
begin
if not IsLightColor(Src.Canvas.Pixels[x, y]) then
begin
Rectangle(x*3+1, y*3+1, x*3+3, y*3+3);
end
end;
end;
Result := TmpMem;
end;
function LoadBMPFile(Filename: String): TBitmap;
begin
TmpMem.LoadFromFile(Filename);
Result := TmpMem;
end;
function DisabledBmp(Src: TBitmap; DisabledColor, FaceColor: TColor): TBitmap;
begin
TmpMem.Assign(Src);
GreyBMP(TmpMem);
BrightenBmp(TmpMem, 50);
Result := TmpMem;
end;
function ResizeBMP(Src: TBitmap; Width, Height: Integer): TBitmap;
var
DR, SR: TRect;
begin
DR := Rect(0, 0, Width, Height);
SR := Rect(0, 0, Src.Width, Src.Height);
TmpMem.Width := Width;
TmpMem.Height := Height;
TmpMem.Canvas.CopyRect(DR, Src.Canvas, SR);
Result := TmpMem;
end;
function BMPFromRes(ResName: String) : TBitmap;
begin
TmpMem.LoadFromResourceName(HINSTANCE, PChar(UpperCase(ResName)));
Result := TmpMem;
end;
procedure BrightenBMP(Bmp : TBitmap; Grade : Integer);
var
i, j : Integer;
p: PRGBArray;
begin
if Bmp.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Bmp.Height-1 do
begin
P := Bmp.Scanline[i];
for j := 0 to Bmp.Width-1 do
begin
P[j] := IntToRGB(BrightenColor(RGBToInt(P[j]), Grade));
end;
end;
end;
procedure DarkenBMP(Bmp : TBitmap; Grade : Integer);
var
i, j : Integer;
p: PRGBArray;
begin
if Bmp.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Bmp.Height-1 do
begin
P := Bmp.Scanline[i];
for j := 0 to Bmp.Width-1 do
begin
P[j] := IntToRGB(DarkenColor(RGBToInt(P[j]), Grade));
end;
end;
end;
procedure BWOnlyBMP(Src : TBitmap);
begin
Src.Monochrome := True;
Src.Monochrome := False;
end;
procedure GreyBMP(Src : TBitmap);
var
i, j : Integer;
p: PRGBArray;
begin
if Src.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Src.Height-1 do
begin
P := Src.Scanline[i];
for j := 0 to Src.Width-1 do
begin
P[j] := IntToRGB(ColorToGrey(RGBToInt(P[j])));
end;
end;
end;
procedure MergeBMP(Pic1, Pic2 : TBitmap);
begin
MergeBMPExt(Pic1, Pic2, 50);
end;
procedure MergeBMPExt(Pic1, Pic2 : TBitmap; Grade: Byte);
var
i, j : Integer;
p1, p2: PRGBArray;
begin
if (Pic1.PixelFormat <> pf24Bit) or (Pic2.PixelFormat <> pf24Bit) then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Pic1.Height-1 do
begin
P1 := Pic1.Scanline[i];
P2 := Pic2.Scanline[i];
for j := 0 to Pic1.Width-1 do
begin
P1[j] := IntToRGB(MergeColorExt(RGBToInt(P1[j]), RGBToInt(P2[j]) ,Grade));
end;
end;
end;
procedure SoftenBMP(Src : TBitmap);
var
SumR, SumG, SumB, i, j, k, l : Integer;
P, G, G1: PRGBArray;
begin
for i := 1 to Src.Height-2 do
begin
P := Src.Scanline[i];
G := Src.Scanline[i+1];
G1 := Src.Scanline[i-1];
for j := 1 to Src.Width-2 do
begin
SumR := P[j][2] + P[j+1][2] + P[j-1][2] + G[j][2] + G1[j][2];
SumG := P[j][1] + P[j+1][1] + P[j-1][1] + G[j][1] + G1[j][1];
SumB := P[j][0] + P[j+1][0] + P[j-1][0] + G[j][0] + G1[j][0];
P[j] := IntToRGB(ERGB(SumR/5, SumG/5, SumB/5));
end;
end;
end;
procedure ColoriseImage(Bmp : TBitmap; BaseColor : TColor);
var
i, j : Integer;
p: PRGBArray;
begin
if Bmp.PixelFormat <> pf24Bit then
begin
EBitmapOperationError.Create('Only 24 bit bitmaps can be operated.');
end;
for i := 0 to Bmp.Height-1 do
begin
P := Bmp.Scanline[i];
for j := 0 to Bmp.Width-1 do
begin
P[j] := IntToRGB(Colorise(RGBToInt(P[j]), BaseColor));
end;
end;
end;
initialization
TmpMem := TBitmap.Create;
finalization
TmpMem.Free;
end.

I also written another unit which is required by the above unit (grafman.pas), it contains all useful function for tile bitmaps, apply a mask to a bitmap, draw a 3D text, etc

Show Code | Download DrawMan.pas

{ ---------------------------------------------------
Drawing Manager Copyright (r) by DreamFactory
Version : 1.75 Author : William Yang
Last Update 10 - Sep - 97
--------------------------------------------------- }
unit DrawMan;
interface
{ ------------------------------------------------------------------------
HOW TO Draw a transparent image
1. Create a mask first.
* Draw a Black & White image with black as the non-transparent area.
2. Create a Storage bitmap.
For store the background image.
1 Copy the background with the size of the transparent image.
2 Paint the Transparent Image on to the Storage Bitmap.
Use CopyMode of cmSrcInvert.
All the colors will be Inverted.
3 Paint the mask on to the storage bitmap.
Use CopyMode of cmSrcAnd.
This will only paint the black area on to the bitmap.
4 Agian paint the Transparent Image on to the Storage Bitmap.
Use CopyMode of cmSrcInvert.
The black area will be painted with the Image.
and the other parts will restore to orignal color.
3. Paint the Storage bitmap on to the Destination Canvas.
See PaintOnMask, PaintOnText.
-------------------------------------------------------------------------}
uses Windows, Classes, Controls ,Graphics, ColorMan, ExtCtrls,
NumMan, SysUtils;
{$I DFDefin.inc}
{Draw a rounded button}
procedure RoundButton(Canvas : TCanvas; Size : TRect;
ButtonColor, SeatColor : TColor; SWidth : Integer );
{Draw a 3D rectangle which the colours are fit the given "Color"}
{Style: 1:Raise, 2:Sunk, 3:Frame}
procedure Draw3D(Dest : TCanvas; Area : TRect; Color : TColor;
Style, Width : Integer);
{Like Frame3D but this is for text}
procedure Draw3DText(Dest : TCanvas; Text: String; X, Y : Integer; HighEdge, LowEdge: TColor);
{Paint Tiled "Src" in "Dest"
Area indicates the painting rectangle }
procedure MultiPaint(Dest : TCanvas; Src : TGraphic; Area : TRect);
{Paint transparent "Bmp" on the "Dest"}
procedure TransparentBlt (Dest : TCanvas; Bmp : TBitmap;
destX, destY : Integer; TransColor : TColor);
{One parameter ignored, TransColor is the first pixel of your bitmap}
procedure TransBlt(Dest : TCanvas; Bmp : TBitmap;
destX, destY : Integer);
{Draw text with shadow}
procedure DrawShadowText(Dest: TCanvas; X, Y : Integer; Text: String);
{Draw the given text with shadow and more options}
{SC : Outline Colour}
procedure DrawShadowTextExt(Dest: TCanvas; X, Y : Integer; Text: String; SC: TColor;
SX, SY: Integer);
//Create a mask for the source bitmap.
function CreateMask(Src: TBitmap; TransColor: TColor): HBitmap;
{Draw the given text and the outlines}
{SC : Outline Colour}
procedure DrawOutlinedText(Dest: TCanvas; X, Y : Integer; Text: String; SC: TColor);
{Draw only the outlines of the given text}
procedure DrawTextOutline(Dest: TCanvas; X, Y : Integer; Text: String; SC: TColor);
{Like multipaint but this can work out the Clipping area
so you dont need to refresh the whole area when repaint,
simply by send Canvas.ClipRect. }
procedure MultiClipPaint(Dest : TCanvas; Src : TBitmap; Area, Clip : TRect);
{This one for paint big picture, it will chop it into small pieces
and paint them on to the dest. (if you have few ram )}
procedure BytesPaint(Dest : TCanvas; Area: TRect; Src : TBitmap);
{This function will give the rect measure in screen mode}
{ClientToScreen only give Point of its parent control }
function GetCtrlRect(const Ctrl: TControl): TRect;
function GetCtrlPoint(const Ctrl: TControl): TPoint;
{Merge rectangles to one piece}
function MergeRect(R : array of TRect): TRect;
{Paint bitmaps on the mask.
the mask must be monochrome.}
procedure StretchPaintOnMask(Dest: TCanvas; X,Y : Integer; XMask, Bmp: TBitmap);
procedure PaintOnMask(Dest: TCanvas; X,Y : Integer; XMask, Bmp: TBitmap);
{ Some functions that will make you a nice text }
{ Paint bitmaps on text
Font can be modified before send the Canvas.
}
procedure PaintOnText(Dest: TCanvas; X,Y : Integer; Text: String; Bmp: TBitmap);
// Stretch the bitmap to fit on the text.
procedure StretchPaintOnText(Dest: TCanvas; X,Y : Integer; Text: String; Bmp: TBitmap);
//Set the size of bitmap rather than Width :=, Height :=.
procedure SetSize(Bitmap: TBItmap; W, H: Integer);
//Check if bitmap is Empty.
function BmpIsNil(Bitmap: TBitmap): Boolean;
procedure TextSmooth(Canvas: TCanvas; X, Y: Integer; Text: String);
procedure SmoothBlt(Canvas: TCanvas; X, Y: Integer; Bmp: TBitmap; Trans: TColor);
function TransColor(Bmp: TBitmap): TColor;
procedure DrawTextAnglo(Canvas: TCanvas; X, Y: Integer; Text: String; Anglo: Integer);
//Read Text Pixels
type
TReadPixelProcs = procedure (Color: TColor);
procedure ReadPixels(Src: TBitmap; ReadProcs: TReadPixelProcs);
//Use canvas so you send the font together.
procedure ReadText(Canvas: TCanvas; Text: String; ReadProcs: TReadPixelProcs);
procedure ChopInto(Bmp: TBitmap; ImageList: TImageList);
implementation
procedure ChopInto(Bmp: TBitmap; ImageList: TImageList);
var
Chop, Mask: TBitmap;
i, Count: Integer;
S, R: TRect;
begin
Chop := TBitmap.Create;
Chop.Width := Bmp.Height;
Count := Bmp.Width div Chop.Width;
Chop.Height := Bmp.Height;
R := Rect(0, 0, Chop.Width, Chop.Height);
S := R;
Mask := TBitmap.Create;
Mask.Width := Chop.Width; Mask.Height := Chop.Height;
for i := 1 to Count do
begin
Chop.Canvas.CopyRect(R, Bmp.Canvas, S);
Mask.Handle := CreateMask(Chop, Chop.TransparentColor);
ImageList.Add(Chop, Mask);
OffsetRect(S, Chop.Width, 0);
end;
Chop.Free;
Mask.Free;
end;
function TransColor(Bmp: TBitmap): TColor;
begin
Result := Bmp.Canvas.Pixels[0, 0];
end;
procedure SSetPixel(Canvas: TCanvas; X, Y: Integer; Color: TColor);
begin
Canvas.Pixels[X, Y] := MergeColorExt(Color, Canvas.Pixels[X, Y], 30);
end;
procedure SmoothBlt(Canvas: TCanvas; X, Y: Integer; Bmp: TBitmap; Trans: TColor);
var
Back: TBitmap;
i,j : Integer;
procedure SmoothPixel(ix, iy, Color: Integer);
begin
Back.Canvas.Pixels[ix, iy] := MergeColorExt(Back.Canvas.Pixels[ix, iy],
Color, 20);
end;
begin
if Trans < 0 then Trans := TransColor(Bmp);
Back := TBitmap.Create;
//the background picture will be slidely larger than the smooth image.
Back.Width := Bmp.Width + 2; //**
Back.Height := Bmp.Height + 2; //**
//Create a background picture make it as small as possible.
Back.Canvas.CopyRect(Rect(0, 0, Back.Width, Back.Width), Canvas,
Bounds(x-1, y-1, Back.Width, Back.Width));
//Paint the image to back picture
TransparentBlt(Back.Canvas, Bmp, 1, 1, Trans);
//Only process the image area. (see **)
for i := 1 to Back.Width-2 do
for j := 1 to Back.Height-2 do
begin
//Not in Image area, becase the size
if Bmp.Canvas.Pixels[i-1, j-1] <> Trans then
begin
if (Bmp.Canvas.Pixels[i-2, j-1] = Trans) then SmoothPixel(i-1, j, Bmp.Canvas.Pixels[i-1, j-1]);
if (Bmp.Canvas.Pixels[i-1, j-2] = Trans) then SmoothPixel(i, j-1, Bmp.Canvas.Pixels[i-1, j-1]);
if (Bmp.Canvas.Pixels[i, j-1] = Trans) then SmoothPixel(i+1, j, Bmp.Canvas.Pixels[i-1, j-1]);
if (Bmp.Canvas.Pixels[i-1, j] = Trans) then SmoothPixel(i, j+1, Bmp.Canvas.Pixels[i-1, j-1]);
end;
end;
Canvas.Draw(x-1, y-1, Back);
Back.Free;
end;
procedure TextSmooth(Canvas: TCanvas; X, Y: Integer; Text: String);
var
Tb, Tmp: TBitmap;
i, j: Integer;
Count, R, G, B: Integer;
procedure AddPixel(row, col: Integer);
var
Color: TColor;
begin
Color := Tb.Canvas.Pixels[row, col];
if Color = $FFFFFF then
begin
Color := (Tmp.Canvas.Pixels[row+1, col+1]);
Inc(R, MulDiv(GetRValue(Color), 2, 3));
Inc(G, MulDiv(GetGValue(Color), 2, 3));
Inc(B, MulDiv(GetBValue(Color), 2, 3));
Inc(Count);
end;
end;
begin
//Paint text to BW bitmap first.
Tb := TBitmap.Create;
Tb.Width := Canvas.TextWidth(Text);
Tb.Height := Canvas.TextHeight(Text);
Tb.Monochrome := True;
Tb.Canvas.Brush.Color := clWhite;
Tb.Canvas.Font.Assign(Canvas.Font);
Tb.Canvas.Font.Color := clBlack;
Tb.Canvas.Textout(0, 0, Text);
Tmp := TBitmap.Create;
Tmp.Width := Tb.Width + 2;
Tmp.Height := Tb.Height + 2;
Tmp.PixelFormat := pf24Bit;
Tmp.Canvas.CopyRect(Rect(0, 0, Tmp.Width, Tmp.Height), Canvas,
Bounds(x-1, y-1, Tmp.Width, Tmp.Height));
for i := 0 to Tb.Width-1 do
for j := 0 to Tb.Height-1 do
begin
if tb.Canvas.Pixels[i, j] = clBlack then
begin
Count := 1;
//get all colors around the pixel
r := 0; g := 0; b := 0;
r := GetRValue(ColorToRGB(Canvas.Font.Color));
g := GetGValue(ColorToRGB(Canvas.Font.Color));
b := GetBValue(ColorToRGB(Canvas.Font.Color));
AddPixel(i-1, j);
AddPixel(i, j-1);
AddPixel(i, j+1);
AddPixel(i+1, j);
Tmp.Canvas.Pixels[i+1, j+1] := RGB(r div Count, g div Count, b div Count);
end;
end;
Canvas.Draw(x, y, Tmp);
Tmp.Free;
Tb.Free;
end;
procedure DrawTextAnglo(Canvas: TCanvas; X, Y: Integer; Text: String; Anglo: Integer);
var
hFont: Integer;
Weight: Integer;
Italic: Integer;
Under: Integer;
Strike: Integer;
Fontname: array[1..32] of Char;
begin
if fsBold in Canvas.Font.Style then Weight := 700 else Weight := 400;
if fsItalic in Canvas.Font.Style then Italic := 1 else Italic := 0;
if fsUnderline in Canvas.Font.Style then Under := 1 else Under := 0;
if fsStrikeout in Canvas.Font.Style then Strike := 1 else Strike := 0;
StrPCopy(@Fontname, Canvas.Font.Name);
hFont := CreateFont(Abs(Canvas.Font.Height), 0, 0, Anglo, Weight,
Italic, Under, Strike, 0, 0, PROOF_QUALITY, DEFAULT_PITCH, 0, @Fontname);
Canvas.Textout(x, y, Text);
DeleteObject(hfont);
end;
procedure ReadPixels(Src: TBitmap; ReadProcs: TReadPixelProcs);
var
i, j : Integer;
begin
for i := 0 to Src.Width do
for j := 0 to Src.Height do
begin
ReadProcs(GetPixel(Src.Canvas.Handle, i, j));
end;
end;
function BmpIsNil(Bitmap: TBitmap): Boolean;
begin
Result := False;
if Bitmap = nil then
begin
Result := True;
Exit;
end;
if (Bitmap.Width = 0) or (Bitmap.Height = 0) then
begin
Result := True;
Exit;
end;
end;
procedure SetSize(Bitmap: TBItmap; W, H: Integer);
begin
Bitmap.Width := W;
Bitmap.Height := H;
end;
procedure ReadText(Canvas: TCanvas; Text: String; ReadProcs: TReadPixelProcs);
var
BWText: TBitmap;
begin
BWText := TBitmap.Create;
BWText.Monochrome := True;
BWText.Width := Canvas.TextWidth(Text);
BWText.Height := Canvas.TextHeight(Text);
//ensure that font.color is Black.
Canvas.Font.Color := clBlack;
BWText.Canvas.Textout(0, 0, Text);
ReadPixels(BWText, ReadProcs);
BWText.Free;
end;
function MergeRect(R: array of TRect): TRect;
var
i: Integer;
begin
//Get the first one, so we compare it to the others
Result := R[Low(R)];
for i := Low(R) + 1 to High(R) do
begin
//Compare the Top/Left point keep the small ones.
Result.Left := Min(Result.Left, R[i].Left);
Result.Top := Min(Result.Top, R[i].Top);
//Compare the Right/Bottom kepp the Big ones
Result.Right := Max(Result.Right, R[i].Right);
Result.Bottom := Max(Result.Bottom, R[i].Bottom);
end;
end;
function GetCtrlRect(const Ctrl: TControl): TRect;
var
FParent : TControl;
begin
FParent := Ctrl;
Result := FParent.ClientRect;
while FParent.HasParent do
begin
if not FParent.Parent.HasParent then Exit;
FParent := FParent.Parent;
OffsetRect(Result, FParent.Left, FParent.Top);
end;
end;
function GetCtrlPoint(const Ctrl: TControl): TPoint;
var
FParent : TControl;
begin
FParent := Ctrl;
with Result do
begin
Result.X := 0; Result.Y := 0;
Result.X := Result.X + Ctrl.Left;
Result.Y := Result.Y + Ctrl.Top;
while FParent.HasParent do
begin
FParent := FParent.Parent;
Result.X := Result.X + FParent.Left;
Result.Y := Result.Y + FParent.Top;
end;
end;
end;
procedure DrawOutlinedText(Dest: TCanvas; X, Y : Integer; Text: String; SC: TColor);
var</

Tiaon Lab

Delphi code part 4 - Bitmap