<%
'------------------
'图片验证码
'netdust
'http://www.oyj.cn
'05-8-29 发布
'05-12-20 修正了一个错误
'06-5-24 加入了干扰线条，字符个数和位置随机，可设置图像的宽、高
'------------------

Option Explicit

Call Com_CreatValidCode("GetCode"&trim(request("s")))

Rem 生成验证码图片
Sub Com_CreatValidCode(pSN)
	Const codeLenMin = 4				'验证码位数范围
	Const codeLenMax = 4				'验证码位数范围
	Const cOdds = 2 						'杂点出现的机率
	Const dbtTimes = 1					'干扰次数
	Const posX = 4							'位置随机范围X
	Const posY = 2							'位置随机范围Y
	ImgWidth = 64							'图像宽(要为4的倍数)
	ImgHeight = 19							'图像高

	Const cAmount = 10 					'字库数量
	Const cCode = "0123456789"	'字库对应的字符
	Const UnitWidth = 16				'字宽(要为4的倍数)
	Const UnitHeight = 15				'字高
	Const DotsLimit = 10				'每次删除有效点的上限(避免无法人为识别)
	Const tryCount = 5					'避免删除有效点超过上限的尝试次数限制

	'-----------

	Randomize
	Dim i,ii,iii,flag,ActUnitWidth,ImgYuWidth,codeLen,ImgWidth,ImgHeight
	codeLen = codeLenMin + cint(Rnd*(codeLenMax-codeLenMin))
	If ImgWidth Mod 4 <> 0 Or ImgWidth < codeLen*UnitWidth Then ImgWidth = codeLen*UnitWidth
	If ImgHeight < UnitHeight Then ImgHeight = UnitHeight

	' 禁止缓存
	Response.Expires = -9999
	Response.AddHeader "Pragma","no-cache"
	Response.AddHeader "cache-ctrol","no-cache"
	Response.ContentType = "Image/BMP"

	' 颜色的数据(字符，背景)
	Dim vColorData(1)
	vColorData(0) = ChrB(0) & ChrB(0) & ChrB(0)  ' 蓝0，绿0，红0（黑色）
	vColorData(1) = ChrB(240) & ChrB(240) & ChrB(238) ' 蓝250，绿236，红211（浅蓝色）

	' 字符的数据(可以自己修改，如果修改了尺寸，记得把前面的设定也改了)
	Dim vNumberData(9)
	vNumberData(0) = "111111111111111111110000000011111110000000000111111001111110011111100111111001111110011111100111111001111110011111100111111001111110011111100111111001111110011111100111111001111110011111100111111000000000011111110000000011111111111111111111"
	vNumberData(1) = "111111111111111111111100011111111111000001111111111000000111111111001100011111111111110001111111111111000111111111111100011111111111110001111111111111000111111111111100011111111111110001111111111000000000111111100000000011111111111111111111"
	vNumberData(2) = "111111111111111111111100000111111111100000001111111100011100111111100011110011111111111110011111111111110011111111111110011111111111110011111111111110011111111111110011110011111110011111001111111000000000111111100000000011111111111111111111"
	vNumberData(3) = "111111111111111111111000000111111111000000001111111001111110011111100111110011111111111110011111111111100011111111111110001111111111111110011111111111111100111111100111111001111110011111100111111100000000111111111000000111111111111111111111"
	vNumberData(4) = "111111111111111111111111001111111111101100111111111100110011111111110011001111111110011100111111110011110011111110000000000000111000000000000011111111110011111111111111001111111111111100111111111111110011111111111111001111111111111111111111"
	vNumberData(5) = "111111111111111111100000000001111100000000000111110011111111111111001111111111111100111111111111110011000000111111000001111001111111111111100111111111111110011111111111111001111100111111100111110011111110011111100000000011111111111111111111"
	vNumberData(6) = "111111111111111111111100000111111111100000001111111100111110011111100111111111111110011111111111111001000001111111100000000011111110001111100111111001111110011111100111111001111110011111100111111100000000111111111000000111111111111111111111"
	vNumberData(7) = "111111111111111111100000000001111110000000000111111001111110011111100111111001111111111111001111111111111100111111111111100111111111111100111111111111110011111111111111001111111111111100111111111111110011111111111111001111111111111111111111"
	vNumberData(8) = "111111111111111111111000000111111111000000001111111001111110011111100111111001111110011111100111111100000000111111110000000011111111001111001111111001111110011111100111111001111110011111100111111100000000111111111000000111111111111111111111"
	vNumberData(9) = "111111111111111111111000000111111111000000001111111001111110011111100111111001111110011111100111111100000000011111110000001001111111111111100111111111111110011111111111111001111110011111001111111100000000111111111000000111111111111111111111"


	' 随机产生字符
	Dim vCodes
	ReDim vCode(codeLen-1)
	For i = 0 To codeLen-1
	  vCode(i) = Int(Rnd * cAmount)
	  vCodes = vCodes & Mid(cCode, vCode(i) + 1, 1)
	  vCode(i) = pcd_doubter(vNumberData(vCode(i)),UnitWidth,UnitHeight,DotsLimit,tryCount,dbtTimes)
	Next

	Session(pSN) = vCodes  '记录入Session

	' 输出图像文件头
	Response.BinaryWrite ChrB(66) & ChrB(77) & Num2ChrB(54+ImgWidth*ImgHeight*3,4) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(54) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(40) & ChrB(0) & ChrB(0) & ChrB(0) & Num2ChrB(ImgWidth,4) & Num2ChrB(ImgHeight,4) & ChrB(1) & ChrB(0)

	' 输出图像信息头
	Response.BinaryWrite ChrB(24) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & Num2ChrB(ImgWidth*ImgHeight*3,4) & ChrB(18) & ChrB(11) & ChrB(0) & ChrB(0) & ChrB(18) & ChrB(11) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)

	' 生成干扰线
	ReDim noiseLine(1,-1)
	Call makeNoise(noiseLine,ImgWidth,ImgHeight)
	Call makeNoise(noiseLine,ImgWidth,ImgHeight)
	' 如果想多画几条直接复制就可以
	' Call makeNoise(noiseLine,ImgWidth,ImgHeight)

	' 位置随机
	ActUnitWidth = Int(ImgWidth / codeLen)
	ImgYuWidth = ImgWidth - ActUnitWidth * codeLen
	ReDim posAry(1,codeLen-1)
	posAry(0,0) = Int((Rnd)*(posX+(ActUnitWidth-UnitWidth)/2))
	posAry(1,0) = Int((ImgHeight-UnitHeight)/2+(1-2*Rnd)*posY)
	For i=1 To codeLen-2
		posAry(0,i) = Int((1-2*Rnd)*(posX+(ActUnitWidth-UnitWidth)/2))
		posAry(1,i) = Int((ImgHeight-UnitHeight)/2+(1-2*Rnd)*posY)
	Next
	If codeLen > 1 Then
		posAry(0,codeLen-1) = Int((Rnd)*(posX+(ActUnitWidth-UnitWidth)/2))
		posAry(1,codeLen-1) = Int((ImgHeight-UnitHeight)/2+(-Rnd)*posY)
	End If

	' 输出图像数据
	For i = ImgHeight-1 To 0 Step -1	'行
	  For ii = 0 To codeLen-1					'字
	  	For iii = 0 To ActUnitWidth-1 		'字宽
		  	flag = 0
		  	If onNoiseLine(noiseLine,ii*ActUnitWidth+iii,i) Then ' 干扰线
		   		flag = 1
	    	ElseIf getUnitDot(posAry,vCode,ii,iii,i,UnitWidth,UnitHeight) = "0" Then
	    		flag = 1
	    	ElseIf getUnitDot(posAry,vCode,ii-1,iii+ActUnitWidth,i,UnitWidth,UnitHeight) = "0" Then
	    		flag = 1
	    	ElseIf getUnitDot(posAry,vCode,ii+1,iii-ActUnitWidth,i,UnitWidth,UnitHeight) = "0" Then
	    		flag = 1
	    	End If
	    	' 随机生成杂点
		    If Rnd * 99 + 1 < cOdds Then flag = 1 - flag
	    	Response.BinaryWrite vColorData(1-flag)
	 		Next
		Next
 		For ii = 0 To ImgYuWidth-1
 			Response.BinaryWrite vColorData(1)
 		Next
	Next
End Sub

Rem 获取单元的点（考虑位移）
Function getUnitDot(ByRef posAry,ByRef vCode,i,ByVal x,ByVal y,UnitWidth,UnitHeight)
	getUnitDot = "1"
	If i < 0 Or i > UBound(vCode) Then Exit Function
	x = x - posAry(0,i)
	If x < 0 Or x >= UnitWidth Then Exit Function
	y = y - posAry(1,i)
	If y < 0 Or y >= UnitHeight Then Exit Function
	getUnitDot = Mid(vCode(i),y*UnitWidth+x+1,1)
End Function

Rem 生成干扰线
Sub makeNoise(ByRef nl,imgW,UnitHeight)
	Dim i,l,x1,y1,x2,y2,dx,dy,deltaT
	x1 = Int(Rnd*imgW)
	y1 = Int(Rnd*UnitHeight)
	x2 = Int(Rnd*imgW)
	y2 = Int(Rnd*UnitHeight)
	dx = X2 - X1
	dy = Y2 - Y1
	If Abs(dx) > Abs(dy) Then deltaT = Abs(dx) Else deltaT = Abs(dy)
	If deltaT = 0 Then Exit Sub
	l = UBound(nl,2)
	ReDim Preserve nl(1,l+deltaT+1)
	l = l + 1
	For i = 0 To deltaT
		nl(0,l+i) = x1 + dx * i \ deltaT
		nl(1,l+i) = y1 + dy * i \ deltaT
	Next
End Sub

Rem 判断是否为干扰线上的点
Function onNoiseLine(ByRef nl,x,y)
	onNoiseLine = False
	Dim i
	For i=0 To UBound(nl,2)
		If x = nl(0,i) And y = nl(1,i) Then
			onNoiseLine = True
			Exit For
		End If
	Next
End Function

Rem 对单个字的点阵进行干扰
Rem 干扰思想：在点阵范围内随机产生2个端点，进行连线，以位移较大的一方做横轴，先将连线上的点删除，再将被删除点的纵轴方向上方或下方的点（随机确定）移向被删除点，移动后的空白用背景色补充
Function pcd_doubter(ByVal str,UnitWidth,UnitHeight,DotsLimit,tryCount,dbtTimes)
	Randomize
	Dim x1,x2,y1,y2,dx,dy,deltaT,i,ii,way,f1,f2
	For f1=1 To dbtTimes	'干扰次数
		For f2=1 To tryCount	'避免删除有效点超过上限的尝试次数限制
			'随机确定2个端点
			x1 = int(Rnd*UnitWidth)
			x2 = int(Rnd*UnitWidth)
			y1 = int(Rnd*UnitHeight)
			y2 = int(Rnd*UnitHeight)
			dx = X2 - X1
			dy = Y2 - Y1
			If Abs(dx) > Abs(dy) Then deltaT = Abs(dx) Else deltaT = Abs(dy)
			ReDim ary(1,deltaT)	'存储连线的点
			If deltaT = 0 Then
				ary(0,0) = x1
				ary(1,0) = y1
			Else
				ii = 0
				For i = 0 To deltaT
					ary(0,i) = x1 + dx * i \ deltaT
					ary(1,i) = y1 + dy * i \ deltaT
					If pcd_getDot(ary(0,i),ary(1,i),str,UnitWidth) = "0" Then ii = ii + 1
				Next
				' 统计连线上有效点的数量,如未超过有效点上限则跳出循环，执行干扰
				If ii <= DotsLimit Then Exit For
			End If
		Next

		' 执行干扰(dx,dy改作不同的方向标记用)
		If Abs(dx) > Abs(dy) Then dx = 1 Else dx = 0
		If dx = 1 Then
			If Int(Rnd*10) > 4 Then
				dy = 1
				way = -1
			Else
				dy = UnitHeight - 2
				way = 1
			End If
		Else
			If Int(Rnd*10) > 4 Then
				dy = 1
				way = -1
			Else
				dy = UnitWidth - 2
				way = 1
			End If
		End If
		For i=0 To deltaT
			For ii=ary(dx,i) To dy Step way
				Call pcd_setDot(ary(0,i)*dx+ii*(1-dx),ary(1,i)*(1-dx)+ii*(dx),str,pcd_getDot(ary(0,i)*dx+(ii+way)*(1-dx),ary(1,i)*(1-dx)+(ii+way)*(dx),str,UnitWidth),UnitWidth)
			Next
			'添补空白
			Call pcd_setDot(ary(0,i)*dx+(dy+way)*(1-dx),ary(1,i)*(1-dx)+(dy+way)*(dx),str,"1",UnitWidth)
		Next
	Next
	pcd_doubter = str
End Function

Rem 得到某点的字符
Function pcd_getDot(x,y,str,UnitWidth)
	pcd_getDot = Mid(str,x+1+y*UnitWidth,1)
End Function

Rem 设置某点的字符
Sub pcd_setDot(x,y,ByRef str,newDot,UnitWidth)
	str = Left(str,x+y*UnitWidth) & newDot & Right(str,Len(str)-x-y*UnitWidth-1)
End Sub

Rem 将数字转为bmp需要的格式 lens是目标字节长度
Function Num2ChrB(ByVal num,lens)
	Dim ret,i
	ret = ""
	While (num>0)
		ret = ret & ChrB(num mod 256)
		num = num \ 256
	WEnd
	For i=Lenb(ret) To lens-1
		ret = ret & chrB(0)
	Next
	Num2ChrB = ret
End Function
%>