canvas.asp

商品订单管理：商品分类管理 添加与修改商品 管理订单 投诉订单 反馈信息 商品留言管理 管理网站用户：管理用户 管理后台管理员 新闻公告管理：新闻添加（支持图片新闻） 修改删除 首页公告设置 网站常规

		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"))
		else
			MagicNumber = MagicNumber & ChrB(Asc("7"))
		end if
		MagicNumber = MagicNumber & ChrB(Asc("a"))
	end function

	' Windows bitmap support
	private function BitmapMagicNumber()
		BitmapMagicNumber = ChrB(Asc("B")) & ChrB(Asc("M"))
	end function

	' File support for reading bitmaps using the ADO Stream object
	public sub LoadBMP(sFilename)
		Dim objStream
		Dim sBMP
		
		set objStream = Server.CreateObject("ADODB.Stream")
		
		objStream.Type = 1 ' adTypeBinary
		objStream.Open
		objStream.LoadFromFile sFilename