wh_bmptext.asp

是一个QQWRY.DAT的ASP利用程序

<%
'=========================================================
' ClassName: Wh_BmpText
' Version:1.0
' Date: 2005-1-15
'=========================================================
' Web: http://vcc5.vicp.net
' Email: [e-mail]
' Oicq:54883661
'=========================================================
Class Wh_BmpText
private offset
private sBMP
private width
private height
private bitcont
private imagesize
private lines
private Conn,rs,Font,Letter(12),FPath
	private Sub AddFont(sText)
		Dim i, Chrs, arr
		Set Font = Server.CreateObject("Scripting.Dictionary")
		For I = 1 to Len(sText)
			chrs = chrs & "'" & Mid(sText,I,1) & "',"
		Next
		Call DBconn()
		Set Rs = Conn.execute("Select * From Font Where chrs in(" & Left(chrs,Len(chrs) -1) & ")")
		If Rs.eof Then Rs.close : Set Rs = Nothing : Call DBclose() : Exit Sub
		do while not rs.eof
			arr = split(rs("font")," ")
			Font.Add "f" & rs("Chrs"),arr
			Rs.movenext
		loop
		Rs.close
		Set Rs = Nothing
		Call DBclose()
	end Sub
	
	public Sub DrawTextNS(lX,lY,sText,color)
		Dim Rs,I,Chrs
		Dim iTemp1
		Dim iTemp2
		Dim iTemp3
		Dim bChar
		if lx = "" or ly = "" or sText = "" or color = "" Then exit Sub
		Call AddFont(sText)
		y=0
		for iTemp1 = 1 to len(sText)
			for iTemp2 = 0 to UBound(Letter) - 1
				x = 0
				for iTemp3 = 1 to len(Font("f" & Mid(sText,iTemp1,1))(iTemp2))
					bChar = Mid(Font("f" & Mid(sText,iTemp1,1))(iTemp2),iTemp3,1)
					If bChar <> "0" Then
						Pixel(lX + x,lY + y) = CLng(color)
					End If
					x = x +1
				next
				y = y +1
			next
		next
		Font.removeall
	End Sub

	public Sub DrawTextWE(lX,lY,sText,color)
		Dim Rs,I,Chrs
		Dim iTemp1
		Dim iTemp2
		Dim iTemp3
		Dim bChar
		Dim x
		if lx = "" or ly = "" or sText = "" or color = "" Then exit Sub
		Call AddFont(sText)	
		For iTemp1 = 0 to UBound(Letter) - 1
			x = 0
			For iTemp2 = 1 to len(sText)
				For iTemp3 = 1 to Len(Font("f" & Mid(sText,iTemp2,1))(iTemp1))
					bChar = Mid(Font("f" & Mid(sText,iTemp2,1))(iTemp1),iTemp3,1)
					If bChar <> "0" Then
						Pixel(lX + x,lY + iTemp1) = CLng(color)
					End If
					x = x +1
				next
			next
		next
		Font.removeall
	End Sub
	
	public property let FontPath(val)
		If val <> "" Then FPath = val
	End property

	public property let Pixel(X,Y,colorindex)
		dim temp
		X = int(X)
		Y = int(Y)
		colorindex = int(colorindex)
		If (X<=width) and (X>0) and (Y<=height) and (Y>0) Then
			temp = (height-Y)*lines+X-1+offset
			sBMP = midB(sBMP,1,temp) & ChrB(colorindex) & midb(sBMP,temp + 2,lenb(sBMP)-temp+2)
		End If
	End property

	public Sub loadBMP(filename)
		dim obj,image
		set obj=server.createobject("adodb.stream")
		obj.Type = 1 ' adTypeBinary
		obj.Open
		obj.LoadFromFile filename
		image = obj.Read
		obj.Close
		set obj = Nothing
		If midb(image,1,2) = (ChrB(Asc("B")) & ChrB(Asc("M"))) Then
			offset = getlong(midb(image,11,4))
			width = getlong(midb(image,19,4))
			height = getlong(midb(image,23,4))
			bitcont = getword(midb(image,29,2))
			imagesize = getlong(midb(image,35,4))
			lines = imagesize / height
			If bitcont = 8 Then
				sBMP = image
			End If
		End If
	End Sub
	
	public Sub write
		If lenb(sBMP)>0 Then
			Response.ContentType = "image/bmp"
			Response.AddHeader "Content-Disposition","filename=Wh_BmpText.bmp"
			Response.BinaryWrite sBMP
		End If
	End Sub

	private 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

	private Function GetWord(sValue)
		GetWord = ShIftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))
	End Function

	private Function ShIftLeft(lValue,lBits)
		ShIftLeft = lValue * (2^lBits)
	End Function

	private Function ShIftRight(lValue,lBits)
		ShIftRight = int(lValue / (2^lBits))
	End Function

	private Sub DBConn()
		set Conn=server.createobject("adodb.Connection")
		Conn.Connectionstring="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FPath
		Conn.open
	end Sub

	private Sub DBclose()
		if isobject(Conn) Then Conn.close : set Conn = Nothing
	End Sub
	
End Class
%>