Jump to content
uniGUI Discussion Forums
devx

How to make Captcha?

Recommended Posts

You can use TUniImage to show the Captcha image. There are several ways to create the Captcha image itself which I believe there are 3rd party tools for it.

Share this post


Link to post
Share on other sites

Heres an example of how you can make your very own captcha component based on TUniImage

 

unit UniCaptcha;

interface
uses
 classes,
 Graphics,
 uniImage;

type TUniCaptcha = class(TUniImage)
 private
   FChallenge : ShortString;
   procedure Render;
 public
   constructor create(Owner : TComponent); override;
   procedure SetChallenge(aChallenge : ShortString);
 published
   property Challenge  : ShortString    read FChallenge   write FChallenge;
end;

procedure Register;

implementation

constructor TUniCaptcha.Create(Owner: TComponent);
begin
 inherited;
end;

procedure TUniCaptcha.SetChallenge(aChallenge: ShortString);
begin
 FChallenge := aChallenge;
 Render;
end;

procedure TUniCaptcha.render;
Var
 b : TBitmap;
 i : Integer;
begin
 b := TBitmap.Create;
 with b do
 begin
   b.Width  := self.Width;
   b.height := self.Height;
   For i := 0 to 30 do begin
     randomize;
     canvas.Pen.Width     := random(5)+5;
     Canvas.Pen.Color     := random(64738)+64738;
     Canvas.Brush.Style   := bsFDiagonal;

     Canvas.Ellipse(random(width),random(Height),random(width),random(height));
   end;
   Canvas.Font.Color := clBlue;
   Canvas.Font.Size  := 18;
   Canvas.TextOut(10,trunc(self.height/2),FChallenge);
   Canvas.Font.Color := clRed;
   Canvas.TextOut(8,trunc(self.height/2)-2,FChallenge);
 end;

 Picture.Assign(;
 b.Free;
end;

procedure Register;
begin
   RegisterComponents('UniCustom', [TUniCaptcha]);
end;

end.

 

you can use it something like this :

procedure TMainForm.UniFormCreate(Sender: TObject);
begin
 //InsertControl();
 UniCaptcha1.SetChallenge('Billybob cheats at cards!');
end;

 

There are loads of different ways to prevent character recognition and to validate, simply compare to the "Challenge" property :)

post-11-0-09517800-1311857100_thumb.png

post-11-0-21159600-1311857108_thumb.png

Share this post


Link to post
Share on other sites

Then using a little sin() magic we can distort it to make it barely readable (Procedure Distort(aBitmap : TBitmap) ;).

 

unit UniCaptcha;

interface
uses
 classes,
 Graphics,
 uniImage;

type TUniCaptcha = class(TUniImage)
 private
   FChallenge : ShortString;
   procedure Render;
   Procedure  Distort(aBitmap : TBitmap) ;
 public
   constructor create(Owner : TComponent); override;
   procedure SetChallenge(aChallenge : ShortString);
 published
   property Challenge  : ShortString    read FChallenge   write FChallenge;
end;

procedure Register;

implementation

constructor TUniCaptcha.Create(Owner: TComponent);
begin
 inherited;
end;

Procedure TUniCaptcha.Distort(aBitmap: TBitmap);
var
 b : TBitmap;
 x,y : integer;
begin
 b := TBitmap.Create;
 b.Width  := aBitmap.Width;
 b.Height := aBitmap.Height;
 for x := 0 to aBitmap.Canvas.ClipRect.Right do
 begin
   for y := 0 to aBitmap.Canvas.ClipRect.Bottom do
   begin
     b.Canvas.Pixels[x,y +trunc(sin(x/4)*4)] :=
       aBitmap.Canvas.Pixels[x,y];
   end;
 end;
 Picture.Assign(;
 b.Free;
end;

procedure TUniCaptcha.SetChallenge(aChallenge: ShortString);
begin
 FChallenge := aChallenge;
 Render;
end;

procedure TUniCaptcha.render;
Var
 b : TBitmap;
 i : Integer;
begin
 b := TBitmap.Create;
 with b do
 begin
   b.Width  := self.Width;
   b.height := self.Height;
   For i := 0 to 30 do begin
     randomize;
     canvas.Pen.Width     := random(5)+5;
     Canvas.Pen.Color     := random(64738)+64738;
     Canvas.Brush.Style   := bsFDiagonal;

     Canvas.Ellipse(random(width),random(Height),random(width),random(height));
   end;
   Canvas.Font.Color := clBlue;
   Canvas.Font.Size  := 18;
   Canvas.TextOut(10,trunc(self.height/2),FChallenge);
   Canvas.Font.Color := clRed;
   Canvas.TextOut(8,trunc(self.height/2)-2,FChallenge);
 end;
 distort(;
 b.Free;
end;

procedure Register;
begin
   RegisterComponents('UniCustom', [TUniCaptcha]);
end;

end.

 

viola! 1 x hacker busting captcha :)

post-11-0-09871800-1311859931_thumb.png

Share this post


Link to post
Share on other sites

Then using a little sin() magic we can distort it to make it barely readable (Procedure Distort(aBitmap : TBitmap) ;).

 

unit UniCaptcha;

interface
uses
 classes,
 Graphics,
 uniImage;

type TUniCaptcha = class(TUniImage)
 private
   FChallenge : ShortString;
   procedure Render;
   Procedure  Distort(aBitmap : TBitmap) ;
 public
   constructor create(Owner : TComponent); override;
   procedure SetChallenge(aChallenge : ShortString);
 published
   property Challenge  : ShortString    read FChallenge   write FChallenge;
end;

procedure Register;

implementation

constructor TUniCaptcha.Create(Owner: TComponent);
begin
 inherited;
end;

Procedure TUniCaptcha.Distort(aBitmap: TBitmap);
var
 b : TBitmap;
 x,y : integer;
begin
 b := TBitmap.Create;
 b.Width  := aBitmap.Width;
 b.Height := aBitmap.Height;
 for x := 0 to aBitmap.Canvas.ClipRect.Right do
 begin
   for y := 0 to aBitmap.Canvas.ClipRect.Bottom do
   begin
     b.Canvas.Pixels[x,y +trunc(sin(x/4)*4)] :=
       aBitmap.Canvas.Pixels[x,y];
   end;
 end;
 Picture.Assign(;
 b.Free;
end;

procedure TUniCaptcha.SetChallenge(aChallenge: ShortString);
begin
 FChallenge := aChallenge;
 Render;
end;

procedure TUniCaptcha.render;
Var
 b : TBitmap;
 i : Integer;
begin
 b := TBitmap.Create;
 with b do
 begin
   b.Width  := self.Width;
   b.height := self.Height;
   For i := 0 to 30 do begin
     randomize;
     canvas.Pen.Width     := random(5)+5;
     Canvas.Pen.Color     := random(64738)+64738;
     Canvas.Brush.Style   := bsFDiagonal;

     Canvas.Ellipse(random(width),random(Height),random(width),random(height));
   end;
   Canvas.Font.Color := clBlue;
   Canvas.Font.Size  := 18;
   Canvas.TextOut(10,trunc(self.height/2),FChallenge);
   Canvas.Font.Color := clRed;
   Canvas.TextOut(8,trunc(self.height/2)-2,FChallenge);
 end;
 distort(;
 b.Free;
end;

procedure Register;
begin
   RegisterComponents('UniCustom', [TUniCaptcha]);
end;

end.

 

viola! 1 x hacker busting captcha :)

 

Two questions:

 

1- It is necessary "constructor" if you only call inherited method???

 

2- procedure TUniCaptcha.SetChallenge(aChallenge: ShortString); is declared, but the property does not use it. It is something missed???

Share this post


Link to post
Share on other sites

One more questions, but in this case about "captcha itself".

 

The use of different colors could help the process of recognition of characters. Will be good to use some lines or circles of the same color across some letters.

 

PS: It is just a comment. Do not put much attention to it.

Share this post


Link to post
Share on other sites

Two questions:

 

1- It is necessary "constructor" if you only call inherited method???

 

Nah.. I was playing with it, left it in in case I want to play with it again later.

 

procedure TUniCaptcha.SetChallenge(aChallenge: ShortString); is declared, but the property does not use it. It is something missed???

 

SetChallenge sets FChallenge := aChallenge.

 

aChallenge is a procedure argument, FChallenge is a private variable.

 

Property Challenge reads and writes FChallenge

 

its not a OO setter, just a method called SetChallenge.

Share this post


Link to post
Share on other sites

One more questions, but in this case about "captcha itself".

 

The use of different colors could help the process of recognition of characters. Will be good to use some lines or circles of the same color across some letters.

 

PS: It is just a comment. Do not put much attention to it.

 

Sure! You can draw whatever you like in there :)

 

The point of the exercise was to illustrate how easily you can use standard canvas drawing techniques with Unigui :)

Share this post


Link to post
Share on other sites

Nah.. I was playing with it, left it in in case I want to play with it again later.

 

 

Ok. You know...

 

 

SetChallenge sets FChallenge := aChallenge.

 

aChallenge is a procedure argument, FChallenge is a private variable.

 

Property Challenge reads and writes FChallenge

 

its not a OO setter, just a method called SetChallenge.

 

It was not necessary the first 3 lines, just the last one. But, because in many codes when you have a property called Prop, then appear an "OO setter" called SetProp.

 

Ok. Thank you anyway for your time.

Share this post


Link to post
Share on other sites

Sure! You can draw whatever you like in there :)

 

The point of the exercise was to illustrate how easily you can use standard canvas drawing techniques with Unigui :)

 

Ok. I understood, and in this case is a help to "the thread starter" and to me too.

 

Thank you.

Share this post


Link to post
Share on other sites

Capctha.png

 

private

{ Private declarations }

validapost: string;

 

function GeraImagem(Img: TUniImage): string;

 

--------------------------------------------------------------------------

 

function TFormEsqueci_Minha_Senha.GeraImagem(Img: TUniImage): string;

const

f: array [0..4] of string = ('Courier New', 'Impact', 'Times New Roman',

'Verdana', 'Arial');

s = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';

C: ARRAY [0..14] OF tcOLOR = (clAqua, clBlack, clBlue, clFuchsia, clGray,

clGreen, clLime, clMaroon, clNavy, clOlive,

clPurple, clRed, clSilver, clTeal, clYellow);

var

i, x, y : integer;

r : string;

 

begin

randomize;

Img.Width := 160;

Img.Height := 60;

for i := 0 to 3 do

r := r + s[Random(length(s)-1)+1];

 

with Img.Picture.Bitmap do

begin

width := Img.Width;

Height := Img.Height;

Canvas.Brush.Color := $00EFEFEF;

Canvas.FillRect(Img.ClientRect);

 

for i := 0 to 3 do

begin

Canvas.Font.Size := random(20) + 20;

Canvas.Font.Name := f[High(f)];

Canvas.Font.Color := c[random(High©)];

Canvas.TextOut(i*40,0,r[i+1]);

end;

 

for i := 0 to 2 do

begin

Canvas.Pen.Color := c[random(High©)];

Canvas.Pen.Width := 2;

canvas.MoveTo(random(Width),0);

Canvas.LineTo(random(Width),Height);

Canvas.Pen.Width := 1;

x := random(Width-10);

y := random(Height-10);

Canvas.Rectangle(x,y,x+10,y+10);

end;

end;

 

Result := r;

 

end;

 

------------------------------------------------------------------

 

procedure TFormEsqueci_Minha_Senha.bt_recuperar_senhaClick(Sender: TObject);

begin

validapost := GeraImagem(UniImage1);

end;

Share this post


Link to post
Share on other sites

Hi , thanks !

I will try it.

 

Note:

It's better for all of us to enclose source code into a code block.

Share this post


Link to post
Share on other sites

changed to better view of all...

 

;)

 

 

 

   private
   { Private declarations }
   validapost: string;

   function GeraImagem(Img: TUniImage): string;

-------------------------------------------------------

function TFormEsqueci_Minha_Senha.GeraImagem(Img: TUniImage): string;
const
 f: array [0..4] of string = ('Courier New', 'Impact', 'Times New Roman',
                              'Verdana', 'Arial');
 s = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
 C: ARRAY [0..14] OF tcOLOR = (clAqua, clBlack, clBlue, clFuchsia, clGray,
                               clGreen, clLime, clMaroon, clNavy, clOlive,
                               clPurple, clRed, clSilver, clTeal, clYellow);
var
 i, x, y : integer;
 r : string;

begin
 randomize;
 Img.Width := 160;
 Img.Height := 60;
 for i := 0 to 3 do
   r := r + s[Random(length(s)-1)+1];

 with Img.Picture.Bitmap do
 begin
   width := Img.Width;
   Height := Img.Height;
   Canvas.Brush.Color := $00EFEFEF;
   Canvas.FillRect(Img.ClientRect);

   for i := 0 to 3 do
   begin
     Canvas.Font.Size := random(20) + 20;
     Canvas.Font.Name := f[High(f)];
     Canvas.Font.Color := c[random(High(c))];
     Canvas.TextOut(i*40,0,r[i+1]);
   end;

   for i := 0 to 2 do
   begin
     Canvas.Pen.Color := c[random(High(c))];
     Canvas.Pen.Width := 2;
     canvas.MoveTo(random(Width),0);
     Canvas.LineTo(random(Width),Height);
     Canvas.Pen.Width := 1;
     x := random(Width-10);
     y := random(Height-10);
     Canvas.Rectangle(x,y,x+10,y+10);
   end;
 end;

 Result := r;

end;

--------------------------------------------------------

procedure TFormEsqueci_Minha_Senha.UniFormShow(Sender: TObject);
begin
 validapost := GeraImagem(UniImage1);
end;

Share this post


Link to post
Share on other sites

Dear colleagues,

may be i'm doing something wrong, but i can't assign bitmat to UniImage :(

 

Simpliest code doesn't work:

    UniImage1.Picture.Bitmap.Canvas.Brush.Color := $00EFEFEF;
    UniImage1.Picture.Bitmap.Canvas.FillRect(UniImage1.ClientRect);

or

var
  b:TBitmap;
begin
  b:=TBitmap.Create;
  b.width:=100;
  b.height:=100;
  b.canvas.brush.color:=clGreen;
  b.canvas.fillrect(UniImage1.ClientRect);
  UniImage1.Picture.Assign(;
  b.free
end;

UniGui 1.0.0.1412

 

 

Question closed. I will use UniCanvas

Share this post


Link to post
Share on other sites

×