What's New
Q & A
Tip Jar
C# Helper...
Follow VBHelper on Twitter
MSDN Visual Basic Community
TitleMake CAPTCHA images (version 1) in VB .NET
DescriptionThis example shows how to make CAPTCHA images (version 1) in VB .NET.
KeywordsCAPTCHA, Turing test, image, image processing, distort image, VB.NET
CategoriesGraphics, Software Engineering
CAPTCHA (Completely Automated Public Turing test to tell Computers and Humans Apart) images are those distorted pictures of words that some Web sites make you enter to prove you are a human and not an automated process. The idea is to distort the characters in the image so it would be hard for an optical character recognition (OCR) application to read them but so it would still be easy for a person to read them.

This example uses a technique based on one described at BrainJar.com.

Function MakeCaptchaImage makes a Bitmap of the desired size and fills it with a hatched pattern. It then tries different font sizes until it finds the largest that will let the specified text fit in the bitmap. It uses a StringFormat object to center the text and then adds it to a GraphicsPath object.

Next the program picks some random points on the bitmap and uses the GraphicsPath object's Warp method to warp the bitmap's bounding rectangle to the points. This distorts the text (and is the hardest part to reproduce in VB 6).

The program then draws the GraphicsPath onto the bitmap. Final steps draw over some ellipses and lines to clutter the image and introduce breaks in the letters to make it harder for OCR software to read.

' Make a captcha image for the text.
Private Function MakeCaptchaImge(ByVal txt As String, ByVal _
    wid As Integer, ByVal hgt As Integer, ByVal _
    font_family_name As String) As Bitmap
    ' Make the bitmap and associated Graphics object.
    Dim bm As New Bitmap(wid, hgt)
    Dim gr As Graphics = Graphics.FromImage(bm)
    gr.SmoothingMode = Drawing2D.SmoothingMode.HighQuality

    Dim rectf As New RectangleF(0, 0, wid, hgt)
    Dim br As Brush
    br = New HatchBrush(HatchStyle.SmallConfetti, _
        Color.LightGray, Color.White)
    gr.FillRectangle(br, rectf)

    Dim text_size As SizeF
    Dim the_font As Font
    Dim font_size As Single = hgt + 1
        font_size -= 1
        the_font = New Font(font_family_name, font_size, _
            FontStyle.Bold, GraphicsUnit.Pixel)
        text_size = gr.MeasureString(txt, the_font)
    Loop While (text_size.Width > wid) OrElse _
        (text_size.Height > hgt)

    ' Center the text.
    Dim string_format As New StringFormat
    string_format.Alignment = StringAlignment.Center
    string_format.LineAlignment = StringAlignment.Center

    ' Convert the text into a path.
    Dim graphics_path As New GraphicsPath
    graphics_path.AddString(txt, the_font.FontFamily, _
        CInt(Font.Style), the_font.Size, rectf, _

    ' Make random warping parameters.
    Dim rnd As New Random
    Dim pts() As PointF = { _
        New PointF(CSng(rnd.Next(wid) / 4), _
            CSng(rnd.Next(hgt) / 4)), _
        New PointF(wid - CSng(rnd.Next(wid) / 4), _
            CSng(rnd.Next(hgt) / 4)), _
        New PointF(CSng(rnd.Next(wid) / 4), hgt - _
            CSng(rnd.Next(hgt) / 4)), _
        New PointF(wid - CSng(rnd.Next(wid) / 4), hgt - _
            CSng(rnd.Next(hgt) / 4)) _
    Dim mat As New Matrix
    graphics_path.Warp(pts, rectf, mat, _
        WarpMode.Perspective, 0)

    ' Draw the text.
    br = New HatchBrush(HatchStyle.LargeConfetti, _
        Color.LightGray, Color.DarkGray)
    gr.FillPath(br, graphics_path)

    ' Mess things up a bit.
    Dim max_dimension As Integer = Max(wid, hgt)
    For i As Integer = 0 To CInt(wid * hgt / 30)
        Dim X As Integer = rnd.Next(wid)
        Dim Y As Integer = rnd.Next(hgt)
        Dim W As Integer = CInt(rnd.Next(max_dimension) / _
        Dim H As Integer = CInt(rnd.Next(max_dimension) / _
        gr.FillEllipse(br, X, Y, W, H)
    Next i
    For i As Integer = 1 To 5
        Dim x1 As Integer = rnd.Next(wid)
        Dim y1 As Integer = rnd.Next(hgt)
        Dim x2 As Integer = rnd.Next(wid)
        Dim y2 As Integer = rnd.Next(hgt)
        gr.DrawLine(Pens.DarkGray, x1, y1, x2, y2)
    Next i
    For i As Integer = 1 To 5
        Dim x1 As Integer = rnd.Next(wid)
        Dim y1 As Integer = rnd.Next(hgt)
        Dim x2 As Integer = rnd.Next(wid)
        Dim y2 As Integer = rnd.Next(hgt)
        gr.DrawLine(Pens.LightGray, x1, y1, x2, y2)
    Next i


    Return bm
End Function
Copyright © 1997-2006 Rocky Mountain Computer Consulting, Inc.   All rights reserved.