canvas.asp

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

<%
' The font pack is included seperately so custom packs can be used
%>
<!--#include file="font.asp"-->
<%
' ***************************************************************
' ************************** ASPCanvas **************************
' ***************************************************************
'
'             Drawing and presentation object for ASP
'
'        Chris Read (aka Centurix/askdaquack/captainscript)
'
'    Thanks to Richard Deeming (www.trinet.co.uk) for improving 
'    the arc drawing algorithm
'    Thanks to Daniel Hasan for bezier curve adjustments
'    Thanks to Tony Stefano for his extra font packs
'
'                            Updated 23/02/2003
'
' ASPCanvas home: http://users.bigpond.net.au/mrjolly/
' ***************************************************************
'
' This file contains the following classes
' Canvas - Main GIF rendering class
' PixelStack - Used to store an order of pixels
' Point - A single pixel coord
' 
' This file contains the following utility functions
' MakeWord - Convert the value to a big-endian word
' MakeByte - Trim value to an 8 bit value
' Blue - Extract Blue value from RGB
' Green - Extract Green value from RGB
' Red - Extract Red value from RGB
' Low - Retrieve the low 8 bits from the value
' High - Retrieve the high 8 bits from the value
' ShiftLeft - Shift the value left x bits
' ShiftRight - Shift the value right x bits
'
' This class requires font.asp for text rendering support
'
' !!!Please read notes.htm for information on using this class!!!
'
' ***************************************************************
' ASPCanvas Copyright (c) 2002, Chris Read. All rights reserved.
' ***************************************************************
' Redistribution and use in source form, with or without modification, 
' are permitted provided that the following conditions are met:
'
' * Redistributions of source code must retain the above copyright notice, 
' this list of conditions and the following disclaimer.
'
' * All advertising materials mentioning features or use of this software 
' must display the following acknowledgement: This product includes software 
' developed by Chris Read with portions contributed by Richard Deeming, 
' Daniel Hasan and Tony Stefano.
'
' * The name of the author may not be used to endorse or promote products 
' derived from this software without specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 
' IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 
' OF MERCHANT ABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 
' IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
' SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
' PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 
' OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 
' WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 
' ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
' POSSIBILITY OF SUCH DAMAGE.
'
' ***************************************************************

' Constants for this class
public const MAX_WIDTH		= 65535
public const MAX_HEIGHT		= 65535
public const INIT_WIDTH		= 20
public const INIT_HEIGHT	= 20
public const FLAG_DEBUG		= false
public const CURRENT_VER	= "01.00.05"
public const PI				= 3.14159265 ' Roughly

Class Canvas
' Public data
	public GlobalColourTable()
	public LocalColourTable()
	public ForegroundColourIndex ' Current foreground pen
	public BackgroundColourIndex ' Current background pen
	public TransparentColourIndex ' Current transparency colour index
	public UseTransparency ' Boolean for writing transparency
	public GIF89a ' Write GIF89a data
	public Comment ' Image comment 255 characters max
	
' Private data
	private sImage
	private lWidth
	private lHeight
	private iBits
	private lColourResolution
	private bSortFlag
	private bytePixelAspectRatio
	private byteSeperator
	private byteGraphicControl
	private byteEndOfImage
	private lLeftPosition
	private lTopPosition
	private lLocalColourTableSize
	private lGlobalColourTableSize
	private lReserved
	private bInterlaceFlag
	private bLocalColourTableFlag
	private bGlobalColourTableFlag
	private lCodeSize
	private bTest
	
' ***************************************************************************
' ************************ Raster management functions **********************
' ***************************************************************************

	public property get Version()
		Version = CURRENT_VER
	end property

	' Get a specific pixel colour
	public property get Pixel(ByVal lX,ByVal lY)
		if lX <= lWidth and lX > 0 and lY <= lHeight and lY > 0 then
			Pixel = AscB(MidB(sImage,(lWidth * (lY - 1)) + lX,1))
		else ' Out of bounds, return zero
			Pixel = 0
		end if
	end property
	
	' Set a specific pixel colour, look at speeding this up somehow...
	public property let Pixel(ByVal lX,ByVal lY,lValue)
		Dim sTemp
		Dim lOffset
		
		lX = int(lX)
		lY = int(lY)
		lValue = int(lValue)

		lOffset = lWidth * (lY - 1)

		if lX <= lWidth and lY <= lHeight and lX > 0 and lY > 0 then ' Clipping
			' Set the pixel value at this point
			sImage = LeftB(sImage,lOffset + (lX - 1)) & ChrB(lValue) & RightB(sImage,LenB(sImage) - (lOffset + lX))
		end if		
	end property

	' Read only width and height, to change these, resize the image
	public property get Width()
		Width = lWidth
	end property

	public property get Height()
		Height = lHeight
	end property

	public sub Replace(ByVal lOldColour,ByVal lNewColour)
		Dim lTempX
		Dim lTempY
		
		for lTempy = 1 to lHeight
			for lTempX = 1 to lWidth
				if Pixel(lTempX,lTempY) = lOldColour then
					Pixel(lTempX,lTempY) = lNewColour
				end if
			next
		next
	end sub

	' Copy a section of the picture from one location to the other
	public sub Copy(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2,ByVal lX3,ByVal lY3)
		Dim sCopy
		Dim lTemp1
		Dim lTemp2
		Dim lStartX
		Dim lStartY
		Dim lFinishX
		Dim lFinishY
		Dim lWidth
		Dim lHeight
		
		if lX1 > lX2 then
			lStartX = lX2
			lFinishX = lX1
		else
			lStartX = lX1
			lFinishX = lX2
		end if
		
		if lY1 > lY2 then
			lStartY = lY2
			lFinishY = lY1
		else
			lStartY = lY1
			lFinishY = lY2
		end if
		
		sCopy = ""
		
		lWidth = lFinishX - lStartX + 1
		lHeight = lFinishY - lStartY + 1

		for iTemp2 = lStartY to lFinishY
			for iTemp1 = lStartX to lFinishX
				sCopy = sCopy & ChrB(Pixel(iTemp1,iTemp2))
			next
		next
		
		for iTemp2 = 1 to lHeight
			for iTemp1 = 1 to lWidth
				Pixel(lX3 + iTemp1,lY3 + iTemp2) = AscB(MidB(sCopy,(iTemp2 - 1) * lWidth + iTemp1,1))
			next
		next
	end sub

	' Non-recursive flood fill, VBScript has a short stack (200 bytes) so recursion won't work
	public sub Flood(ByVal lX,ByVal lY)
		Dim aPixelStack
		Dim objPixel
		Dim lOldPixel

		Set aPixelStack = New PixelStack
		
		aPixelStack.Push lX,lY
		
		lOldPixel = Pixel(lX,lY)
		
		while(aPixelStack.Size > 0)
			Set objPixel = aPixelStack.Pop
			
			if objPixel.X >= 1 and objPixel.X <= lWidth and objPixel.Y >= 1 and objPixel.Y <= lHeight then
				if Pixel(objPixel.X,objPixel.Y) <> ForegroundColourIndex and Pixel(objPixel.X,objPixel.Y) = lOldPixel then
					Pixel(objPixel.X,objPixel.Y) = ForegroundColourIndex
					
					aPixelStack.Push objPixel.X + 1,objPixel.Y
					aPixelStack.Push objPixel.X - 1,objPixel.Y
					aPixelStack.Push objPixel.X,objPixel.Y + 1
					aPixelStack.Push objPixel.X,objPixel.Y - 1
				end if
			end if
		wend
	end sub


	public sub Polygon(aX,aY,bJoin)
		Dim iTemp
		Dim lUpper

		if UBound(aX) <> UBound(aY) then exit sub
		if UBound(aX) < 1 then exit sub ' Must be more than one point
		
		lUpper = UBound(aX) - 1
		
		' Draw a series of lines from arrays aX and aY
		for iTemp = 1 to lUpper
			Line aX(iTemp - 1),aY(iTemp - 1),aX(iTemp),aY(iTemp)
		next
		
		if bJoin then
			Line aX(lUpper),aY(lUpper),aX(0),aY(0)
		end if
	end sub

	' Easy as, err, rectangle?
	public sub PieSlice(lX,lY,lRadius,sinStartAngle,sinArcAngle,bFilled)
		Dim sinActualAngle
		Dim sinMidAngle
		Dim lX2
		Dim lY2
		Dim iTemp
		
		Arc lX,lY,lRadius,lRadius,sinStartAngle,sinArcAngle
		AngleLine lX,lY,lRadius,sinStartAngle
		sinActualAngle = sinStartAngle + sinArcAngle
		if sinActualAngle > 360 then
			sinActualAngle = sinActualAngle - 360
		end if
		AngleLine lX,lY,lRadius,sinActualAngle
		' Now pick a start flood point at the furthest point from the center
		' Divide the arc angle by 2
		sinMidAngle = sinStartAngle + (sinArcAngle / 2)
		
		if sinMidAngle > 360 then
			sinMidAngle = sinMidAngle - 360
		end if

		if bFilled then
			for iTemp = 1 to lRadius - 1
				lY2 = CInt(lY + (Sin(DegreesToRadians(sinMidAngle)) * iTemp))
				lX2 = CInt(lX + (Cos(DegreesToRadians(sinMidAngle)) * iTemp))

				Flood lX2,lY2
			next
		end if
	end sub

	public sub Bezier(lX1,lY1,lCX1,lCY1,lCX2,lCY2,lX2,lY2,lPointCount)
		Dim sinT
		dim lX,lY,lLastX,lLastY
		dim sinResolution
		
		if lPointCount = 0 then exit sub
		
		sinResolution = 1 / lPointCount
		
		sinT = 0
		
		lLastX = lX1
		lLastY = lY1
		
		while sinT <= 1
			lX = int(((sinT^3) * -1 + (sinT^2) * 3 + sinT * -3 + 1) * lX1 + ((sinT^3) *  3 + (sinT^2) *-6 + sinT *  3) * lCX1 + ((sinT^3) * -3 + (sinT^2) * 3) * lCX2 + (sinT^3) * lX2)
			lY = int(((sinT^3) * -1 + (sinT^2) * 3 + sinT * -3 + 1) * lY1 + ((sinT^3) *  3 + (sinT^2) *-6 + sinT *  3) * lCY1 + ((sinT^3) * -3 + (sinT^2) * 3) * lCY2 + (sinT^3) * lY2)

			Line lLastX,lLastY,lX,lY
			
			lLastX = lX
			lLastY = lY
			
			sinT = sinT + sinResolution
		wend

		Line lLastX,lLastY,lX2,lY2
		
	end sub

	' ArcPixel Kindly donated by Richard Deeming (www.trinet.co.uk)
	Private Sub ArcPixel(lX, lY, ltX, ltY, sinStart, sinEnd)
		Dim dAngle
	    
	    If ltX = 0 Then
	        dAngle = Sgn(ltY) * PI / 2
	    ElseIf ltX < 0 And ltY < 0 Then
	        dAngle = PI + Atn(ltY / ltX)
	    ElseIf ltX < 0 Then
	        dAngle = PI - Atn(-ltY / ltX)
	    ElseIf ltY < 0 Then
	        dAngle = 2 * PI - Atn(-ltY / ltX)
	    Else
	        dAngle = Atn(ltY / ltX)
	    End If
	    
	    If dAngle < 0 Then dAngle = 2 * PI + dAngle

		' Compensation for radii spanning over 0 degree marker
		if sinEnd > DegreesToRadians(360) and dAngle < (sinEnd - DegreesToRadians(360)) then
			dAngle = dAngle + DegreesToRadians(360)
		end if
		
	    If sinStart < sinEnd And (dAngle > sinStart And dAngle < sinEnd) Then
	        'This is the "corrected" angle
	        'To change back, change the minus to a plus
	        Pixel(lX + ltX, lY + ltY) = ForegroundColourIndex
	    End If
	End Sub
	 
	' Arc Kindly donated by Richard Deeming (www.trinet.co.uk), vast improvement on the
	' previously kludgy Arc function.
	Public Sub Arc(ByVal lX, ByVal lY, ByVal lRadiusX, ByVal lRadiusY, ByVal sinStartAngle, ByVal sinArcAngle)
		' Draw an arc at point lX,lY with radius lRadius
		' running from sinStartAngle degrees for sinArcAngle degrees
		Dim lAlpha, lBeta, S, T, lTempX, lTempY
		Dim dStart, dEnd
	    
	    dStart = DegreesToRadians(sinStartAngle)
	    dEnd = dStart + DegreesToRadians(sinArcAngle)
	    
	    lAlpha = lRadiusX * lRadiusX
	    lBeta = lRadiusY * lRadiusY
	    lTempX = 0
	    lTempY = lRadiusY
	    S = lAlpha * (1 - 2 * lRadiusY) + 2 * lBeta
	    T = lBeta - 2 * lAlpha * (2 * lRadiusY - 1)
	    ArcPixel lX, lY, lTempX, lTempY, dStart, dEnd
	    ArcPixel lX, lY, -lTempX, lTempY, dStart, dEnd
	    ArcPixel lX, lY, lTempX, -lTempY, dStart, dEnd
	    ArcPixel lX, lY, -lTempX, -lTempY, dStart, dEnd

	    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

	        ArcPixel lX, lY, lTempX, lTempY, dStart, dEnd
	        ArcPixel lX, lY, -lTempX, lTempY, dStart, dEnd
	        ArcPixel lX, lY, lTempX, -lTempY, dStart, dEnd
	        ArcPixel lX, lY, -lTempX, -lTempY, dStart, dEnd

	    Loop While lTempY > 0
	End Sub

	public sub AngleLine(ByVal lX,ByVal lY,ByVal lRadius,ByVal sinAngle)
		' Draw a line at an angle
		' Angles start from the top vertical and work clockwise
		' Work out the destination defined by length and angle
		Dim lX2
		Dim lY2
		
		lY2 = (Sin(DegreesToRadians(sinAngle)) * lRadius)
		lX2 = (Cos(DegreesToRadians(sinAngle)) * lRadius)
		
		Line lX,lY,lX + lX2,lY + lY2
	end sub

	' Bresenham line algorithm, this is pretty quick, only uses point to point to avoid the
	' mid-point problem
	public sub Line(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2)
		Dim lDX
		Dim lDY
		Dim lXIncrement
		Dim lYIncrement
		Dim lDPr
		Dim lDPru
		Dim lP
		
		lDX = Abs(lX2 - lX1)
		lDY = Abs(lY2 - lY1)
		
		if lX1 > lX2 then
			lXIncrement = -1
		else
			lXIncrement = 1
		end if
		
		if lY1 > lY2 then
			lYIncrement = -1
		else
			lYIncrement = 1
		end if
		
		if lDX >= lDY then
			lDPr = ShiftLeft(lDY,1)
			lDPru = lDPr - ShiftLeft(lDX,1)
			lP = lDPr - lDX
			
			while lDX >= 0
				Pixel(lX1,lY1) = ForegroundColourIndex
				if lP > 0 then
					lX1 = lX1 + lXIncrement
					lY1 = lY1 + lYIncrement
					lP = lP + lDPru
				else