Jump to content

How to make Captcha?


Recommended Posts

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

Link to comment
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

Link to comment
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???

Link to comment
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.

Link to comment
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.

Link to comment
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 :)

Link to comment
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.

Link to comment
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.

Link to comment
Share on other sites

  • 1 year later...

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;

Link to comment
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;

Link to comment
Share on other sites

  • 5 years later...

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

Link to comment
Share on other sites

Please sign in to comment

You will be able to leave a comment after signing in



Sign In Now
×
×
  • Create New...