» Delphi codeTiaon Lab - PHP, Delphi programming blog

Archive for the 'Delphi code' Category

Delphi HTMLParser - Sample 1 - Reading tags

Monday, July 30th, 2007

HTMLParser is really easy to use. I have made an sample project for anyone who likes to use HTMLParser for their project.

Assume you have downloaded HTMLParser , and have extracted the files into your library directory.

First you need to drop the following items to your form.

Memo1: TMemo;
Edit1: TEdit;
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
txtTitle: TEdit;
txtDescription: TEdit;
txtKeywords: TEdit;
Memo2: TMemo;

HTMLParser Sample 1 - reading tag screenshot

2. Add the following code.

Show Code

procedure TForm1.Button1Click(Sender: TObject);
begin
if (OpenDialog1.Execute) then
begin
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
fHTML := THTMLObject.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fHTML.Free;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
fHTML.LoadFromStrings(Memo1.Lines);
UpdateFields;
end;

3. Create a new procedure in Form1.

This method is used to make calls to fHTML to get TITLE tag, Description and Keywords meta tag

Show Code

procedure TForm1.UpdateFields;
var
i: Integer;
metatag: TTagObject;
begin
//Get title content, just like in Javascipt, tagobject has innerText property
txtTitle.Text := fHTML.TagByName['TITLE'].innerText;
//Specify which tag we need look for
fHTML.TagName := 'META';
// Reset tag array index to first
fHTML.First;
// Look for next META tag
metatag := fHTML.Next;
while metatag <> nil do
begin
if metatag.CompareValue('NAME', 'DESCRIPTION') or metatag.CompareValue('HTTP-EQUIV', 'DESCRIPTION') then
begin
txtDescription.Text := metatag.ReadString('CONTENT', '');
end else
if metatag.CompareValue('NAME', 'KEYWORDS') or metatag.CompareValue('HTTP-EQUIV', 'KEYWORDS') then
begin
txtKeywords.Text := metatag.ReadString('CONTENT', '');
end;
metatag := fHTML.Next;
end;
end;

4. At this point you can already run this program, you should be able click Browse (button1) to parse any file on your computer or paste the HTML content from clipboard.

The following code is to show you how to get all A tags from an HTML content

Show Code

procedure TForm1.Button2Click(Sender: TObject);
var
i: Integer;
metatag: TTagObject;
begin
fHTML.TagName := 'A';
// Reset tag array index to first
fHTML.First;
// Look for next A tag
metatag := fHTML.Next;
Memo2.Lines.Clear;
while metatag <> nil do
begin
Memo2.Lines.Add(metatag._RS('href', '(empty url)'));
metatag := fHTML.Next;
end;
end;

Download full source code

Posted in Delphi code | 2 Comments »

REST web service with Delphi

Monday, March 26th, 2007

When I was looking for examples of how to make REST calls in Delphi 7, I found
XML-RPC for Delphi. XML-RPC for Delphi is an object library that utilises Open Source Indy Components and helps your application connects REST web service. XML-RPC comes full source code and some examples, but does not come any documentation.

Here is a round up of what XML-RPC supports:

Basic data types, string, interger, datetime etc.
Array data type
Struct data type
Automatic data type conversion between Delphi data type and REST data type
Base64 string conversion

I am current using XML-RPC to develop a Wordpress client in Delphi. I will post more result and findings in the future.

Posted in Delphi code | No Comments »

Delphi code part 4 - Bitmap

Wednesday, March 7th, 2007

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;