[All Versions] Real Captcha

[WiseRock]

Ever wanted this in your Game to Block away the damn ducking Bots?

>! 

Here's Your Chance This is a Fairly Small Tut so here we go

1.First go and create a new mod called modCaptcha

Add this in the new mod

```
Option Explicit

Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y

Public Sub MakeCaptchaImage(ByVal pic As PictureBox, ByVal txt As String, ByVal min_size As Integer, ByVal max_size As Integer)
Dim wid As Single
Dim hgt As Single
Dim ch_wid As Single
Dim i As Integer
Dim font_size As Single
Dim ch As String
Dim X As Single
Dim Y As Single
Dim prev_angle As Single
Dim angle As Single
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single

' See how much room is available for each character.
wid = pic.ScaleWidth
hgt = pic.ScaleHeight
ch_wid = wid / Len(txt)

' Draw each character.
prev_angle = 0
pic.Cls
Randomize
For i = 1 To Len(txt)
' Get the character and font size.
ch = Mid$(txt, i, 1)
font_size = min_size + Rnd * (max_size - min_size)

' Get the position.
X = (i - 0.75 + Rnd * 0.5) * ch_wid
Y = hgt / 2 + Rnd * (hgt - pic.ScaleY(font_size, vbPoints, vbTwips))

' Get the angle.
angle = prev_angle
Do While Abs(angle - prev_angle) < 10
angle = -20 + Rnd * (20 - -20)
Loop
prev_angle = angle

' Draw the next character.
DrawCenteredRotatedText frmMenu.picCaptcha, ch, X, Y, angle, font_size
Next i

' Mess things up a bit.
For i = 1 To 10
x1 = Rnd * wid
y1 = Rnd * hgt
x2 = Rnd * wid
y2 = Rnd * hgt
pic.Line (x1, y1)-(x2, y2)
Next i
For i = 1 To 10
x1 = Rnd * wid
y1 = Rnd * hgt
x2 = Rnd * wid
y2 = Rnd * hgt
pic.Line (x1, y1)-(x2, y2), vbWhite
Next i
End Sub
Private Sub DrawCenteredRotatedText(ByVal pic As PictureBox, ByVal txt As String, ByVal X As Single, ByVal Y As Single, ByVal angle As Single, ByVal font_points As Integer)
Const CLIP_LH_ANGLES As Long = 16 ' Needed for tilted fonts.
Const PI As Single = 3.14159265

Dim font_units As Single
Dim escapement As Long
Dim oldfont As Long
Dim newfont As Long
Dim wid As Single
Dim hgt As Single
Dim wx As Single
Dim wy As Single
Dim hx As Single
Dim hy As Single
Dim theta As Single
Dim ox As Single
Dim oy As Single

font_units = font_points * GetDeviceCaps(pic.hdc, LOGPIXELSY) / 72
escapement = CLng(angle * 10)
newfont = CreateFont(CLng(font_units), 0, escapement, escapement, 700, _
False, False, False, 0, 0, CLIP_LH_ANGLES, 0, 0, "Times New Roman")
' Select the new font.
oldfont = SelectObject(pic.hdc, newfont)

' Get the text width.
wid = pic.TextWidth(txt)

' Convert the font height in points into twips.
hgt = pic.ScaleY(font_points, vbPoints, vbTwips)

theta = -angle * PI / 180 ' Negate because y increases downward.
wx = wid * Cos(theta) / 2
wy = wid * Sin(theta) / 2
hx = -hgt * Sin(theta) / 2
hy = hgt * Cos(theta) / 2

' Find the rotated origin.
ox = X - wx - hx
oy = Y - wy - hy

' Display the text.
pic.CurrentX = ox
pic.CurrentY = oy
pic.Print txt

' Restore the original font.
newfont = SelectObject(pic.hdc, oldfont)

' Free font resources (important!)
DeleteObject newfont

' Draw the center point.
' pic.Circle (X, Y), 30, vbRed

' Draw the rotated bounding box.
' pic.CurrentX = X - wx - hx
' pic.CurrentY = Y - wy - hy
' pic.Line -(X + wx - hx, Y + wy - hy), vbBlue
' pic.Line -(X + wx + hx, Y + wy + hy), vbBlue
' pic.Line -(X - wx + hx, Y - wy + hy), vbBlue
' pic.Line -(X - wx - hx, Y - wy - hy), vbBlue
End Sub
[size]
[/size]
[size]Then next go to [color]modGeneral [/color]
in the [color]Sub Main[/color]
after[/size]
[size][/size][code]EngineInitFontSettings[/code]

Insert
[code]Call MakeCaptchaImage(frmMenu.picCaptcha, "My Text", 30, 35)[/code][color]TIP: REPLACE MY TEXT WITH YOUR OWN COSTUM TEXT [/color]
[img]http://www.touchofdeathforums.com/community/public/style_emoticons/default/smile.png[/img]

Next Go to frmMenu
[img]http://i50.tinypic.com/bgtpu0.png[/img]

Hit F7 to Reveal Code

Add
[code]Private Sub picCaptcha_Click()
Call MakeCaptchaImage(picCaptcha, "AMETHYST13", 30, 35)
End Sub
[size]
[/size]
[size]to the Bottom of the mod[/size]
[size]Next goto[/size]
[size][/size][code]If isLoginLegal(Name, Password) Then
If Password <> PasswordAgain Then
Call MsgBox("Passwords don't match.")
Exit Sub
End If[/code][size]add this after the end if[/size]
[size][/size][code]If Code <> "MY TEXT" Then
Call MsgBox("Captcha Incorrect!")
Call MakeCaptchaImage(frmMenu.picCaptcha, "MY TEXT[size]", 30, 35)
Exit Sub
End If[/size]

[size]
[size]Now go to Form Load then[/size]
[size]add this before the End Sub[/size]
[size][/size][code]picCaptcha.AutoRedraw = True[/code][size]Now You Should have a cool looking Captcha[/size]

I did not make this. I really don't who made I found this in 2009 on some fourms.[/size][/code][/code]
```

[abhi2011]

```

If Code <> "MY TEXT" Then

Call MsgBox("Captcha Incorrect!")

Call MakeCaptchaImage(frmMenu.picCaptcha, "MY TEXT", 30, 35)

Exit Sub

End If

```
I fixed the sub. And you should give credits to the person who made the sub that creates the actual captcha. And use a RandomString function to make a random string. (Randomness of captcha is what makes it special)

[DMF]

intresting hope this works for those dat want it.

[tslusny]

RandomString function:

```

Public Function RandomString( _

ByVal length As Long, _

Optional charset As String = "abcdefghijklmnopqrstuvwxyz0123456789" _

) As String

Dim chars() As Byte, value() As Byte, chrUprBnd As Long, i As Long

If length > 0& Then

Randomize

chars = charset

chrUprBnd = Len(charset) - 1&

length = (length * 2&) - 1&

ReDim value(length) As Byte

For i = 0& To length Step 2&

value(i) = chars(CLng(chrUprBnd * Rnd) * 2&)

Next

End If

RandomString = value

End Function

```

[cheatking]

Wait, people get bots in their games?

[tslusny]

> Wait, people get bots in their games?

I had bots probably in my game.

[WiseRock]

> RandomString function:
>
> ```
>
> Public Function RandomString( _
>
> ByVal length As Long, _
>
> Optional charset As String = "abcdefghijklmnopqrstuvwxyz0123456789" _
>
> ) As String
>
> Dim chars() As Byte, value() As Byte, chrUprBnd As Long, i As Long
>
> If length > 0& Then
>
> Randomize
>
> chars = charset
>
> chrUprBnd = Len(charset) - 1&
>
> length = (length * 2&) - 1&
>
> ReDim value(length) As Byte
>
> For i = 0& To length Step 2&
>
> value(i) = chars(CLng(chrUprBnd * Rnd) * 2&)
>
> Next
>
> End If
>
> RandomString = value
>
> End Function
>
> ```

I'll update the tutorial in a sec thanks

[DMF]

looking good  debuged yet?