Administrators Farshad Mohajeri Posted July 26, 2011 Administrators Posted July 26, 2011 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. Quote
JasonReid Posted July 28, 2011 Posted July 28, 2011 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 Quote
JasonReid Posted July 28, 2011 Posted July 28, 2011 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 Quote
Administrators Farshad Mohajeri Posted July 28, 2011 Administrators Posted July 28, 2011 Cool! Thanks for sharing. Quote
dionel1969 Posted July 28, 2011 Posted July 28, 2011 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??? Quote
dionel1969 Posted July 28, 2011 Posted July 28, 2011 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. Quote
JasonReid Posted July 28, 2011 Posted July 28, 2011 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. Quote
JasonReid Posted July 28, 2011 Posted July 28, 2011 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 Quote
dionel1969 Posted July 28, 2011 Posted July 28, 2011 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. Quote
dionel1969 Posted July 28, 2011 Posted July 28, 2011 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. Quote
Marlon Nardi Posted November 3, 2012 Posted November 3, 2012 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; Quote
lema Posted November 3, 2012 Posted November 3, 2012 Hi , thanks ! I will try it. Note: It's better for all of us to enclose source code into a code block. Quote
Marlon Nardi Posted November 3, 2012 Posted November 3, 2012 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; Quote
Kast2k Posted November 28, 2017 Posted November 28, 2017 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 Quote
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.