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

• 关 键 词：
• netscape
• vbscript
• windows
• server
• update

 public sub Circle(ByVal lX,ByVal lY,ByVal lRadius)
  Ellipse lX,lY,lRadius,lRadius
 end sub

 ' Bresenham ellispe, pretty quick also, uses reflection, so rotation is out of the
 ' question unless we perform a matrix rotation after rendering the ellipse coords
 public sub Ellipse(ByVal lX,ByVal lY,ByVal lRadiusX,ByVal lRadiusY)
  ' Draw a circle at point lX,lY with radius lRadius
  Dim lAlpha,lBeta,S,T,lTempX,lTempY
  
  lAlpha = lRadiusX * lRadiusX
  lBeta = lRadiusY * lRadiusY
  lTempX = 0
  lTempY = lRadiusY
  S = lAlpha * (1 - 2 * lRadiusY) + 2 * lBeta
  T = lBeta - 2 * lAlpha * (2 * lRadiusY - 1)
  Pixel(lX + lTempX,lY + lTempY) = ForegroundColourIndex
  Pixel(lX - lTempX,lY + lTempY) = ForegroundColourIndex
  Pixel(lX + lTempX,lY - lTempY) = ForegroundColourIndex
  Pixel(lX - lTempX,lY - lTempY) = ForegroundColourIndex
  Do
   if S < 0 then
    S = S + 2 * lBeta * (2 * lTempX + 3)
    T = T + 4 * lBeta * (lTempX + 1)
    lTempX = lTempX + 1
   elseif T < 0 then
    S = S + 2 * lBeta * (2 * lTempX + 3) - 4 * lAlpha * (lTempY - 1)
    T = T + 4 * lBeta * (lTempX + 1) - 2 * lAlpha * (2 * lTempY - 3)
    lTempX = lTempX + 1
    lTempY = lTempY - 1
   else
    S = S - 4 * lAlpha * (lTempY - 1)
    T = T - 2 * lAlpha * (2 * lTempY - 3)
    lTempY = lTempY - 1
   end if
   Pixel(lX + lTempX,lY + lTempY) = ForegroundColourIndex
   Pixel(lX - lTempX,lY + lTempY) = ForegroundColourIndex
   Pixel(lX + lTempX,lY - lTempY) = ForegroundColourIndex
   Pixel(lX - lTempX,lY - lTempY) = ForegroundColourIndex
  loop while lTempY > 0
 end sub

 ' Vector font support
 ' These fonts are described in terms of points on a grid with simple
 ' X and Y offsets. These functions take elements of a string and render
 ' them from arrays storing character vector information. Vector fonts are
 ' have proportional widths, unlike bitmapped fonts which are fixed in size
 ' The format for the vector array is simply a variable length list of x y pairs
 ' the sub DrawVectorChar renders the single character from the array.
 ' The other advantage of vector fonts is that they can be scaled :)

 ' Maybe add an angle value?
 public sub DrawVectorTextWE(ByVal lX,ByVal lY,sText,lSize)
  Dim iTemp
  Dim lCurrentStringX
  
  lCurrentStringX = lX
  
  For iTemp = 1 to Len(sText)
   lCurrentStringX = lCurrentStringX + DrawVectorChar(lCurrentStringX,lY,Mid(sText,iTemp,1),lSize,true) + int(lSize)
  Next
 end sub
 
 public sub DrawVectorTextNS(ByVal lX,ByVal lY,sText,lSize)
  Dim iTemp
  Dim lCurrentStringY
  
  lCurrentStringY = lY
  
  For iTemp = 1 to Len(sText)
   lCurrentStringY = lCurrentStringY + DrawVectorChar(lX,lCurrentStringY,Mid(sText,iTemp,1),lSize,false) + int(lSize)
  Next
 end sub
 
 private function DrawVectorChar(ByVal lX,ByVal lY,sChar,lSize,bOrientation)
  Dim iTemp
  Dim aFont
  Dim lLargestWidth
  
  if sChar <> " " then
   aFont = VFont(sChar)
  
   if bOrientation then
    lLargest = aFont(1,0) * lSize
   else
    lLargest = aFont(1,1) * lSize
   end if
  
   for iTemp = 1 to UBound(aFont,1) - 1
    if bOrientation then
     if aFont(iTemp,2) = 1  then ' Pen down
      Line lX + aFont(iTemp - 1,0) * lSize,lY + aFont(iTemp - 1,1) * lSize,lX + aFont(iTemp,0) * lSize,lY + aFont(iTemp,1) * lSize
     end if
     if (aFont(iTemp,0) * lSize) > lLargest then
      lLargest = aFont(iTemp,0) * lSize
     end if
    else
     if aFont(iTemp,2) = 1 then ' Pen down
      Line lX + aFont(iTemp - 1,0) * lSize,lY + aFont(iTemp - 1,1) * lSize,lX + aFont(iTemp,0) * lSize,lY + aFont(iTemp,1) * lSize
     end if
     if (aFont(iTemp,1) * lSize) > lLargest then
      lLargest = aFont(iTemp,1) * lSize
     end if
    end if
   next
  else
   lLargest = lSize * 3
  end if
  
  ' Return the width of the character
  DrawVectorChar = lLargest
 end function

 ' Bitmap font support
 public sub DrawTextWE(ByVal lX,ByVal lY,sText)
  ' Render text at lX,lY
  ' There's a global dictionary object called Font and it should contain all the
  ' letters in arrays of a 5x5 grid
  Dim iTemp1
  Dim iTemp2
  Dim iTemp3
  Dim bChar
  
  For iTemp1 = 0 to UBound(Letter) - 1
   For iTemp2 = 1 to len(sText)
    For iTemp3 = 1 to Len(Font(Mid(sText,iTemp2,1))(iTemp1))
     bChar = Mid(Font(Mid(sText,iTemp2,1))(iTemp1),iTemp3,1)
     if bChar <> "0" then
      Pixel(lX + ((iTemp2 - 1) * Len(Letter(0))) + iTemp3,lY + iTemp1) = CLng(bChar)
     end if
    next
   next
  next
 end sub

 public sub DrawTextNS(ByVal lX,ByVal lY,sText)
  ' Render text at lX,lY
  ' There's a global dictionary object called Font and it should contain all the
  ' letters in arrays of a 5x5 grid
  Dim iTemp1
  Dim iTemp2
  Dim iTemp3
  Dim bChar

  for iTemp1 = 1 to len(sText)
   for iTemp2 = 0 to UBound(Letter) - 1
    for iTemp3 = 1 to len(Font(Mid(sText,iTemp1,1))(iTemp2))
     bChar = Mid(Font(Mid(sText,iTemp1,1))(iTemp2),iTemp3,1)
     if bChar <> "0" then
      Pixel(lX + iTemp3,lY + (iTemp1 * (UBound(Letter) + 1)) + iTemp2) = CLng(bChar)
     end if
    next
   next
  next
 end sub

 ' Clear the image, because String sends out UNICODE characters, we double up the index as a WORD
 public sub Clear()
  ' Possibly quicker, but a little less accurate
  sImage = String(lWidth * ((lHeight + 1) / 2),ChrB(BackgroundColourIndex) & ChrB(BackgroundColourIndex))
 end sub
 
 public sub Resize(ByVal lNewWidth,ByVal lNewHeight,bPreserve)
  ' Resize the image, don't stretch
  Dim sOldImage
  Dim lOldWidth
  Dim lOldHeight
  Dim lCopyWidth
  Dim lCopyHeight
  Dim lX
  Dim lY
  
  if bPreserve then
   sOldImage = sImage
   lOldWidth = lWidth
   lOldHeight = lHeight
  end if

  lWidth = lNewWidth
  lHeight = lNewHeight

  Clear
  
  if bPreserve then
   ' Now copy the old image into the new
   if lNewWidth > lOldWidth then
    lCopyWidth = lOldWidth
   else
    lCopyWidth = lNewWidth
   end if
  
   if lNewHeight > lOldHeight then
    lCopyHeight = lOldHeight
   else
    lCopyHeight = lNewHeight
   end if

   ' Now set the new width and height
   lWidth = lNewWidth
   lHeight = lNewHeight
  
   ' Copy the old bitmap over, possibly could do with improvement, this does it
   ' on a pixel leve, there is room here to perform a MidB from one string to another
   for lY = 1 to lCopyHeight
    for lX = 1 to lCopyWidth
     Pixel(lX,lY) = AscB(MidB(sOldImage,(lOldWidth * (lY - 1)) + lX,1))
    next
   next
  end if
 end sub
 
' ***************************************************************************
' ************************* GIF Management functions ************************
' ***************************************************************************
 
 public property get TextImageData()
  Dim iTemp
  Dim sText
  
  sText = ImageData
   
  TextImageData = ""
   
  for iTemp = 1 to LenB(sText)
   TextImageData = TextImageData & Chr(AscB(Midb(sText,iTemp,1)))
  next
 end property
 
 ' Dump the image out as a GIF 87a
 public property get ImageData()
  Dim sText
  Dim lTemp  
  
  ImageData = MagicNumber
  ImageData = ImageData & MakeWord(lWidth)
  ImageData = ImageData & MakeWord(lHeight)
  ImageData = ImageData & MakeByte(GlobalDescriptor)
  ImageData = ImageData & MakeByte(BackgroundColourIndex)
  ImageData = ImageData & MakeByte(bytePixelAspectRatio)
  ImageData = ImageData & GetGlobalColourTable

  if GIF89a then
   ' Support for extended blocks
   if UseTransparency then
    ImageData = ImageData & MakeByte(byteGraphicControl)
    ImageData = ImageData & MakeByte(&HF9)
    ImageData = ImageData & MakeByte(&H04)
    ImageData = ImageData & MakeByte(1)
    ImageData = ImageData & MakeWord(0)
    ImageData = ImageData & MakeByte(TransparentColourIndex)
    ImageData = ImageData & MakeByte(0)
   end if
   if Comment <> "" then
    ImageData = ImageData & MakeByte(byteGraphicControl)
    ImageData = ImageData & MakeByte(&HFE)
    sText = Left(Comment,255) ' Truncate to 255 characters
    ImageData = ImageData & MakeByte(Len(sText))
    For lTemp = 1 to Len(sText)
     ImageData = ImageData & MakeByte(Asc(Mid(sText,lTemp,1)))
    Next
    ImageData = ImageData & MakeByte(0)
   end if
  end if
  
  ImageData = ImageData & MakeByte(byteSeperator)
  ImageData = ImageData & MakeWord(lLeftPosition)
  ImageData = ImageData & MakeWord(lTopPosition)
  ImageData = ImageData & MakeWord(lWidth)
  ImageData = ImageData & MakeWord(lHeight)
  ImageData = ImageData & MakeByte(LocalDescriptor)
  ImageData = ImageData & MakeByte(lCodeSize)
  ImageData = ImageData & GetRasterData
  ImageData = ImageData & MakeByte(0)
  ImageData = ImageData & MakeByte(byteEndOfImage)
  
 end property
 
 public sub Write()
  if bTest then
   ' Write out the bytes in ASCII
   Response.Write Debug(ImageData)
  else
   ' Fix from Daniel Hasan so that duplicate headers don't get sent to confuse Netscape
   Response.ContentType = "image/gif"
   ' Correct content disposition, so that when saving the image through the browser
   ' the filename and type comes up as image.gif instead of an asp file
   Response.AddHeader "Content-Disposition","filename=image.gif"
   Response.BinaryWrite ImageData
  end if
 end sub
 
 private function Debug(sGIF)
  Debug = "<pre>"
  for iTemp = 1 to LenB(sGIF)
   Debug = Debug & right("00" & Hex(AscB(MidB(sGIF,iTemp,1))),2) & " "
   
   if iTemp mod 2 = 0 then
    Debug = Debug & "<font color=red>|</font>"
   end if
   
   if iTemp mod 32 = 0 then
    Debug = Debug & "<br>"'<font color = blue >"&(iTemp/32+1)+10&"</font> "
   end if
  next
  Debug = Debug & "</pre>"
 end function
 
 ' Retrieve the raster data from the image
 private function GetRasterData()
  GetRasterData = UncompressedData
 end function
 
 ' Uncompressed data to avoid UNISYS royalties for LZW usage
 ' As of 1.0.4, this undertook a major overhaul and now writes
 ' gif data at almost 6 times the speed of the old algorithm...
 private function UncompressedData()
  Dim lClearCode
  Dim lEndOfStream
  Dim lChunkMax
  Dim sTempData
  Dim iTemp
  Dim sTemp
  
  UncompressedData = ""
  lClearCode = 2^iBits
  lChunkMax = 2^iBits - 2
  lEndOfStream = lClearCode + 1
  
  sTempData = ""
  
  ' Insert clearcodes where necessary
 ' response.Write debug(sImage)
 ' response.End
  for iTemp = 1 to LenB(sImage) step lChunkMax
   sTempData = sTempData & MidB(sImage,iTemp,lChunkMax) & ChrB(lClearCode)
  next
  
  ' Split the data up into blocks, could possibly speed this up with longer MidB's
  for iTemp = 1 to LenB(sTempData) step 255
   sTemp = MidB(sTempData,iTemp,255)
   UncompressedData = UncompressedData & MakeByte(LenB(sTemp)) & sTemp
  next

  ' Terminate the raster data
  UncompressedData = UncompressedData & MakeByte(0)
  UncompressedData = UncompressedData & MakeByte(lEndOfStream)
 end function

 private function GetGlobalColourTable()
  ' Write out the global colour table
  Dim iTemp
  
  GetGlobalColourTable = ""
  
  for iTemp = 0 to UBound(GlobalColourTable) - 1
   
   GetGlobalColourTable = GetGlobalColourTable & MakeByte(Red(GlobalColourTable(iTemp)))
   GetGlobalColourTable = GetGlobalColourTable & MakeByte(Green(GlobalColourTable(iTemp)))
   GetGlobalColourTable = GetGlobalColourTable & MakeByte(Blue(GlobalColourTable(iTemp)))
   
  next
  
 end function
 
 private function GetLocalColourTable()
  ' Write out a local colour table
  Dim iTemp
  
  GetLocalColourTable = ""
  
  for iTemp = 0 to UBound(LocalColourTable) - 1
   GetLocalColourTable = GetLocalColourTable & MakeByte(Red(LocalColourTable(iTemp)))
   GetLocalColourTable = GetLocalColourTable & MakeByte(Green(LocalColourTable(iTemp)))
   GetLocalColourTable = GetLocalColourTable & MakeByte(Blue(LocalColourTable(iTemp)))
  next
 end function
 
 private function GlobalDescriptor()
  GlobalDescriptor = 0
  
  if bGlobalColourTableFlag then
   GlobalDescriptor = GlobalDescriptor or ShiftLeft(1,7)
  end if
  
  GlobalDescriptor = GlobalDescriptor or ShiftLeft(lColourResolution,4)
  
  if bSortFlag then
   GlobalDescriptor = GlobalDescriptor or ShiftLeft(1,3)
  end if
  
  GlobalDescriptor = GlobalDescriptor or lGlobalColourTableSize
 end function
 
 private function LocalDescriptor()
  LocalDescriptor = 0
  if bLocalColourTableFlag then
   LocalDescriptor = LocalDescriptor or ShiftLeft(1,7)
  end if
  
  if bInterlaceFlag then
   LocalDescriptor = LocalDescriptor or ShiftLeft(1,6)
  end if
  
  if bSortFlag then
   LocalDescriptor = LocalDescriptor or ShiftLeft(1,5)
  end if
  
  LocalDescriptor = LocalDescriptor or ShiftLeft(lReserved,3)
  
  LocalDescriptor = LocalDescriptor or lLocalColourTableSize
 end function
 
 ' Retrieve the MagicNumber for a GIF87a/GIF89a
 private function MagicNumber()
  MagicNumber = ""
  MagicNumber = MagicNumber & ChrB(Asc("G"))
  MagicNumber = MagicNumber & ChrB(Asc("I"))
  MagicNumber = MagicNumber & ChrB(Asc("F"))
  MagicNumber = MagicNumber & ChrB(Asc("8"))
  if GIF89a then
   MagicNumber = MagicNumber & ChrB(Asc("9"))
  else
   MagicNumber = MagicNumber & ChrB(Asc("7"))
  end if
  MagicNumber = MagicNumber & ChrB(Asc("a"))
 end function

 ' Windows bitmap support
 private function BitmapMagicNumber()
  BitmapMagicNumber = ChrB(Asc("B")) & ChrB(Asc("M"))
 end function

 ' File support for reading bitmaps using the ADO Stream object
 public sub LoadBMP(sFilename)
  Dim objStream
  Dim sBMP
  
  set objStream = Server.CreateObject("ADODB.Stream")
  
  objStream.Type = 1 ' adTypeBinary
  objStream.Open
  objStream.LoadFromFile sFilename

  sBMP = objStream.Read
  
  objStream.Close
  
  set objStream = Nothing
  
  DecodeBMP sBMP
 end sub

 public sub SaveBMP(sFilename)
  Dim objStream
  Dim objRS
  Dim sBMP
  Dim aBMP()
  Dim lTemp

  sBMP = EncodeBMP
  
  set objStream = Server.CreateObject("ADODB.Stream")
  
  objStream.Type = 1 ' adTypeBinary
  objStream.Open
  objStream.Write ASCIIToByteArray(EncodeBMP)
  objStream.SaveToFile sFilename,2
  objStream.Close
  
  set objStream = Nothing
 end sub

 ' ASCIIToByteArray converts ASCII strings to a byte array
 ' a byte array is different from an array of bytes, some things require
 ' a byte array, such as writing to the ADODB stream. This function
 ' utilises the ADODB ability to convert to byte arrays from dual digit HEX strings...
 private function ASCIIToByteArray(sText)
  Dim objRS
  Dim lTemp
  Dim sTemp

  sTemp = ""
  
  ' Convert the string to dual digit zero padded hex,
  ' there ain't no quick way of doing this... Would be interested to hear
  ' if anyone do this quicker...
  For lTemp = 1 to LenB(sText)
   sTemp = sTemp & Right("00" & Hex(AscB(MidB(sText,lTemp,1))),2)
  Next
  
  ' Ok, this may look a little weird, but trust me, this works...
  ' Open us a recordset
  set objRS = Server.CreateObject("ADODB.Recordset")
  
  ' Add a fields to the current recordset, add the hex string
  objRS.Fields.Append "Temp",204,LenB(sText)
  objRS.Open
  objRS.AddNew
  objRS("Temp") = sTemp ' ADODB will convert here
  objRS.Update
  objRS.MoveFirst
  
  ASCIIToByteArray = objRS("Temp") ' A variant byte array is returned
  
  objRS.Close
  
  set objRS = Nothing
 end function

【深 度 阅 读】 相 关 文 章

• 精华ASP代码收集
• 经典！5分钟编写一个ASP论坛
• 教你1小时里搞定ASP（精典）
• 1小时ASP入门，非常简单