canvas.asp

功能完善网站统计系统,网络编程从入门到精通

					lX1 = lX1 + lXIncrement
					lP = lP + lDPr
				end if
				lDX = lDX - 1
			wend
		else
			lDPr = ShiftLeft(lDX,1)
			lDPru = lDPr - ShiftLeft(lDY,1)
			lP = lDPR - lDY
			
			while lDY >= 0
				Pixel(lX1,lY1) = ForegroundColourIndex
				if lP > 0 then
					lX1 = lX1 + lXIncrement
					lY1 = lY1 + lYIncrement
					lP = lP + lDPru
				else
					lY1 = lY1 + lYIncrement
					lP = lP + lDPr
				end if
				lDY = lDY - 1
			wend
		end if
		
	end sub

	public sub Rectangle(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2)
		' Easy as pie, well, actually pie is another function... draw four lines
		Line lX1,lY1,lX2,lY1
		Line lX2,lY1,lX2,lY2
		Line lX2,lY2,lX1,lY2
		Line lX1,lY2,lX1,lY1
	end sub

	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"))