ASP生成图片验证码，不需要组件

来源：csdn 作者：domino 出处：巧巧读书 2007-04-09 进入讨论组

' Read a 256 colour bitmap into the canvas from an ASCII string of values
' Bitmaps were chosen because it provides the following:
' * Easy access to the colour table

' * 256 colour support which is strikingly similar to GIF colour support
' * Direct byte for byte copying for the bitmap data
' * No compression, quicker loading and converting
public function DecodeBMP(sBuffer)
  Dim lOffset
  Dim lNewWidth
  Dim lNewHeight
  Dim lBPP
  Dim lCompression
  Dim lImageSize
  Dim lTemp
  Dim lColourIndex
  Dim lPad
  Dim lLineSize
  Dim sLine
  Dim sBitmap

  ' Check the magic number
  if MidB(sBuffer,1,2) = BitmapMagicNumber then
   lOffset = GetLong(MidB(sBuffer,11,4))
   lNewWidth = GetLong(MidB(sBuffer,19,4))
   lNewHeight = GetLong(MidB(sBuffer,23,4))
   lBPP = GetWord(MidB(sBuffer,29,2))
   lCompression = GetLong(MidB(sBuffer,31,4))
   lImageSize = GetLong(MidB(sBuffer,35,4))

   ' Check the vital statistics of the image before proceeding
   ' The criteria for the image is as follows:
   ' 8 Bits per pixel
   ' No compression
   if lBPP = 8 and lCompression = 0 then
    ' Ok, so we have the header data for the bitmap, now we reformat the image
    ' Image is resized, nothing is preserved
    Resize lNewWidth,lNewHeight,False

    lColourIndex = 0

    ' Process the palette values, 256 RGBQUAD values in total
    For lTemp = 55 to 1079 Step 4
     GlobalColourTable(lColourIndex) = RGB(AscB(MidB(sBuffer,lTemp + 2,1)),AscB(MidB(sBuffer,lTemp + 1,1)),AscB(MidB(sBuffer,lTemp,1)))
     lColourIndex = lColourIndex + 1
    Next

    ' Ok, we have width, height, and a valid colour table
    ' now we read the bitmap data directly into the string array
    ' all line lengths MUST be a multiple of 4, so we work out
    ' the padding (if any)
    lPad = 4 - (lNewWidth Mod 4) ' We remove this many bytes from the end of each line

    if lPad = 4 then lPad = 0

    ' Actual line width in the file
    lLineSize = lNewWidth + lPad

    ' Bitmap information starts from the bottom line of the image and works
    ' its way up
    sBitmap = MidB(sBuffer,lOffset + 1,lImageSize) ' Get the bitmap data

    ' Reset sImage
    sImage = ""

    ' Copy the data directly into the canvas, byte for byte
    For lTemp = 1 to LenB(sBitmap) Step lLineSize
     sImage = MidB(sBitmap,lTemp,lNewWidth) & sImage
    Next
   end if
  end if
end function

' Dump a 256 colour bitmap as an ASCII string of values
public function EncodeBMP()
  Dim sTemp
  Dim lTemp
  Dim lImageSize
  Dim lFileSize
  Dim lPad
  Dim sBitmap
  Dim sPad

  sTemp = sTemp & MakeWord(0) ' Reserved (2)
  sTemp = sTemp & MakeWord(0) ' Reserved (2)
  sTemp = sTemp & MakeLong(1078) ' Offset (4)
  sTemp = sTemp & MakeLong(40) ' Headersize (4)
  sTemp = sTemp & MakeLong(lWidth) ' Width (4)
  sTemp = sTemp & MakeLong(lHeight) ' Height (4)
  sTemp = sTemp & MakeWord(1) ' Planes (2)
  sTemp = sTemp & MakeWord(8) ' BPP (2)
  sTemp = sTemp & MakeLong(0) ' Compression (4)

  lPad = 4 - (lWidth Mod 4)

  if lPad = 4 then lPad = 0

  lImageSize = (lWidth + lPad) * lHeight

  sTemp = sTemp & MakeLong(lImageSize) ' Image Size(4)

  sTemp = sTemp & MakeLong(0) ' Pixels per meter X (4)
  sTemp = sTemp & MakeLong(0) ' Pixels per meter Y (4)
  sTemp = sTemp & MakeLong(256) ' Colours used (4)
  sTemp = sTemp & MakeLong(256) ' Important colours (4)
  ' RGBQUAD arrays (BGRX)
  For lTemp = 0 to UBound(GlobalColourTable) - 1
   sTemp = sTemp & MakeByte(Blue(GlobalColourTable(lTemp)))
   sTemp = sTemp & MakeByte(Green(GlobalColourTable(lTemp)))
   sTemp = sTemp & MakeByte(Red(GlobalColourTable(lTemp)))
   sTemp = sTemp & MakeByte(0) ' Pad
  Next
  ' Image lines from the bottom up, padded to the closest 4 pixels

  sPad = ""
  ' Make a pad for the end of each line
  for lTemp = 1 to lPad
   sPad = sPad & Chr(0)
  Next

  sBitmap = ""
  ' Do each line
  for lTemp = 1 to LenB(sImage) step lWidth
   sBitmap = MidB(sImage,lTemp,lWidth) & sPad & sBitmap
  next

  sTemp = sTemp & sBitmap

  lFileSize = LenB(sTemp) + 6

  ' Magic number (2) and size of the file in bytes (4)
  sTemp = BitmapMagicNumber & MakeLong(lFileSize) & sTemp

  EncodeBMP = sTemp
end function

private function DecimalToBinary(lNumber)
  Dim lTemp
  Dim bFound

  DecimalToBinary = ""

  bFound = False

  for lTemp = 7 to 0 step - 1
   if lNumber and 2^lTemp then
    DecimalToBinary = DecimalToBinary & "1"
    bFound = True
   elseif bFound then
    DecimalToBinary = DecimalToBinary & "0"
   end if
  next

  if DecimalToBinary = "" then DecimalToBinary = "0"
end function

private sub DumpBinary(sBlock,lBitLength,bClose)
  if bClose then
   Response.Write "<pre>"
  end if

  for lTemp = 1 to LenB(sBlock)
   ' Write out the binary
   Response.Write " "
   for lTemp2 = lBitLength-1 to 0 step -1
    if AscB(MidB(sBlock,lTemp,1)) and 2^lTemp2 then
     Response.Write "1"
    else
     Response.Write "0"
    end if
   next
   if lTemp Mod lBitLength = 0 then
    Response.Write "<br>"
   end if
  next

  if bClose then
   Response.Write "</pre>"
  end if
end sub

public sub WebSafePalette()
  ' Reset the colours to the web safe palette
  Dim iTemp1
  Dim iTemp2
  Dim iTemp3
  Dim lIndex

  iIndex = 0

  For iTemp1 = &HFF0000& to 0 step - &H330000&
   For iTemp2 = &HFF00& to 0 step - &H3300&
    For iTemp3 = &HFF& to 0 step - &H33&
     GlobalColourTable(iIndex) = iTemp1 or iTemp2 or iTemp3
     iIndex = iIndex + 1
    Next
   Next
  Next
end sub

private sub Class_Initialize()
sImage = "" ' Raster data

GIF89a = False ' Default to 87a data

  ReDim GlobalColourTable(256) ' Start with a 256 colour global table
  lGlobalColourTableSize = 7
  bGlobalColourTableFlag = true

  ReDim LocalColourTable(0) ' No local table support yet
  lLocalColourTableSize = 0
  bLocalColourTableFlag = false

  ' All the 7's
  lColourResolution = 7
  iBits = 7 ' Always 7 bit data (128 colours)
  lCodeSize = 7

  BackgroundColourIndex = 0

  BackgroundColourIndex = 0
  ForegroundColourIndex = 1
  TransparentColourIndex = 0
  UseTransparency = False

  lLeftPosition = 0
  lTopPosition = 0
  lWidth = INIT_WIDTH
  lHeight = INIT_HEIGHT

  Clear

  bytePixelAspectRatio = 0

bSortFlag = false
bInterlaceFlag = false

  byteSeperator = Asc(",")
  byteGraphicControl = Asc("!")
  byteEndOfImage = Asc(";")

  Comment = ""

lReserved = 0
bTest = FLAG_DEBUG
end sub

private sub Class_Terminate()
end sub
End Class

' Pixel stack for certain pixel operations (like floodfill etc.)
Class PixelStack
Private aPoints()

Public Sub Push(lX,lY)
  ' Add these coords to the stack
  ReDim Preserve aPoints(UBound(aPoints) + 1)

  set aPoints(UBound(aPoints)) = new Point

  aPoints(UBound(aPoints)).X = lX
  aPoints(UBound(aPoints)).Y = lY
End Sub

Public function Pop()
  ' Get and remove the last coords from the stack
  Set Pop = aPoints(UBound(aPoints))

  ReDim Preserve aPoints(UBound(aPoints) - 1)
End function

Public Property Get Size()
  Size = UBound(aPoints)
End Property

Private Sub Class_Initialize()
  ReDim aPoints(0)
End Sub

Private Sub Class_Terminate()
End Sub
End Class

' Simple point class
Class Point
Public X
Public Y
End Class

' ***************************************************************************
' ******************* Utility functions for this class **********************
' ***************************************************************************

function GetLong(sValue)
GetLong = 0
if LenB(sValue) >= 4 then
GetLong = ShiftLeft(GetWord(MidB(sValue,3,2)),16) or GetWord(MidB(sValue,1,2))
end if
end function

function MakeLong(lValue)
Dim lLowWord
Dim lHighWord

lLowWord = lValue and 65535
lHighWord = ShiftRight(lValue,16) and 65535

MakeLong = MakeWord(lLowWord) & MakeWord(lHighWord)
end function

' Get a number from a big-endian word
function GetWord(sValue)
GetWord = ShiftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))
end function

' Make a big-endian word
function MakeWord(lValue)
MakeWord = ChrB(Low(lValue)) & ChrB(High(lValue))
end function

' Filter out the high byte
function MakeByte(lValue)
MakeByte = ChrB(Low(lValue))
end function

function Blue(lValue)
Blue = Low(ShiftRight(lValue,16))
end function

function Green(lValue)
Green = Low(ShiftRight(lValue,8))
end function

function Red(lValue)
Red = Low(lValue)
end function

' Low byte order
function Low(lValue)
Low = lValue and 255
end function

' High byte order
function High(lValue)
High = ShiftRight(lValue,8)
end function

' Shift all bits left
function ShiftLeft(lValue,lBits)
ShiftLeft = lValue * (2^lBits)
end function

' Shift all bits right
function ShiftRight(lValue,lBits)
ShiftRight = int(lValue / (2^lBits))
end function

function DegreesToRadians(ByVal sinAngle)
DegreesToRadians = sinAngle * (PI/180)
end function

function RadiansToDegrees(ByVal sinAngle)
RadiansToDegrees = sinAngle * (180/PI)
end function
%>

建立Safecode.asp文件

<%

Dim objCanvas
Dim PointX,PointY,PointColor
Dim iTemp
Dim SafeCode
Dim R,G,B,cc,kk

    Const cAmount = 36 ' 文字数量
    Const cCode = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
cc=80
kk=27
SafeCode = ""
Session("SafeCode") = ""

BGColor = "FFFFFF"

R = Mid(BGColor,1,2)
G = Mid(BGColor,3,2)
B = Mid(BGColor,5,2)


R = DecHex(R)
G = DecHex(G)
B = DecHex(B)

Set objCanvas = New Canvas

objCanvas.GlobalColourTable(0) = RGB(255,255,255) ' White
objCanvas.GlobalColourTable(1) = RGB(0,0,0) ' Black
objCanvas.GlobalColourTable(2) = RGB(255,0,0) ' Red
objCanvas.GlobalColourTable(3) = RGB(0,255,0) ' Green
objCanvas.GlobalColourTable(4) = RGB(0,0,255) ' Blue
objCanvas.GlobalColourTable(5) = RGB(128,0,0)
objCanvas.GlobalColourTable(6) = RGB(0,128,0)
objCanvas.GlobalColourTable(7) = RGB(0,0,128)
objCanvas.GlobalColourTable(8) = RGB(128,128,0)
objCanvas.GlobalColourTable(9) = RGB(0,128,128)
objCanvas.GlobalColourTable(10) = RGB(128,0,128)
objCanvas.GlobalColourTable(11) = RGB(R,G,B)

objCanvas.BackgroundColourIndex = 11

objCanvas.Resize cc,kk,false

'Randomize timer
'SafeCode = cint(8999*Rnd+1000)

    Randomize
For i = 0 To 3
SafeCode = SafeCode &" "& Mid(cCode, Int(Rnd * cAmount) + 1, 1)
    Next
'杂点

For iTemp = 0 To 30
  Randomize timer
  PointX = Int(Rnd * cc)
  PointY = Int(Rnd * kk)
  PointColor = Int(Rnd * 3)+2
  objCanvas.ForegroundColourIndex = PointColor
  objCanvas.Line PointX,PointY,PointX,PointY

next
'边框
objCanvas.ForegroundColourIndex = 1
objCanvas.Line 1,1,cc,1
objCanvas.Line 1,kk,1,1
objCanvas.Line 1,kk,cc,kk
objCanvas.Line cc,1,cc,kk

Session("SafeCode") = SafeCode
dim sc,sk
'文字
Randomize timer
sc = cint(3*Rnd)
sk = cint(3*Rnd)
objCanvas.DrawTextWE sc,sk,SafeCode
objCanvas.Write

Function DecHex (HStr)

Dim Result
Dim i,L

Result = 0

L = Len(Hstr)

For i = L-1 To 0 Step -1

Result = Result + (16 ^ i)*GetDecBit(Mid(HStr,i+1,1))

Next

DecHex = Result

End Function

Function GetDecBit (HStr)

Dim Result
Dim R(16)
Dim i

Result = 0

R(0) = "0"
R(1) = "1"
R(2) = "2"
R(3) = "3"
R(4) = "4"
R(5) = "5"
R(6) = "6"
R(7) = "7"
R(8) = "8"
R(9) = "9"
R(10) = "A"
R(11) = "B"
R(12) = "C"
R(13) = "D"
R(14) = "E"
R(15) = "F"

For i = 0 To 15

  if HStr=R(i) Then Result = i : Exit For

Next

GetDecBit = Result

End Function
%>