canvas.asp

完整的九洲问吧。优秀的问答网站。由ASP+Access开发。

<!--#include file="font.asp"-->
<%
' Constants for this class
public const MAX_WIDTH		= 65535
public const MAX_HEIGHT		= 65535
public const INIT_WIDTH		= 40
public const INIT_HEIGHT	= 40
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
					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