canvas.asp

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

		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

		sBMP = objStream.Read
		
		objStream.Close
		
		set objStream = Nothing
		
		DecodeBMP sBMP
	end sub

	public sub SaveBMP(sFilename)
		Dim objStream
		Dim objRS
		Dim sBMP
		Dim aBMP()
		Dim lTemp

		sBMP = EncodeBMP
		
		set objStream = Server.CreateObject("ADODB.Stream")
		
		objStream.Type = 1 ' adTypeBinary
		objStream.Open
		objStream.Write ASCIIToByteArray(EncodeBMP)
		objStream.SaveToFile sFilename,2
		objStream.Close
		
		set objStream = Nothing
	end sub

	' ASCIIToByteArray converts ASCII strings to a byte array
	' a byte array is different from an array of bytes, some things require
	' a byte array, such as writing to the ADODB stream. This function
	' utilises the ADODB ability to convert to byte arrays from dual digit HEX strings...
	private function ASCIIToByteArray(sText)
		Dim objRS
		Dim lTemp
		Dim sTemp

		sTemp = ""
		
		' Convert the string to dual digit zero padded hex, 
		' there ain't no quick way of doing this... Would be interested to hear
		' if anyone do this quicker...
		For lTemp = 1 to LenB(sText)
			sTemp = sTemp & Right("00" & Hex(AscB(MidB(sText,lTemp,1))),2)
		Next
		
		' Ok, this may look a little weird, but trust me, this works...
		' Open us a recordset
		set objRS = Server.CreateObject("ADODB.Recordset")
		
		' Add a fields to the current recordset, add the hex string
		objRS.Fields.Append "Temp",204,LenB(sText)
		objRS.Open
		objRS.AddNew
		objRS("Temp") = sTemp ' ADODB will convert here
		objRS.Update
		objRS.MoveFirst
		
		ASCIIToByteArray = objRS("Temp") ' A variant byte array is returned
		
		objRS.Close
		
		set objRS = Nothing
	end function

	' Read a 256 colour bitmap into the canvas from an ASCII string of values
	' Bitmaps were chosen because it provides the following:
	' * Easy access to the colour table
	' * 256 colour support which is strikingly similar to GIF colour support
	' * Direct byte for byte copying for the bitmap data
	' * No compression, quicker loading and converting
	public function DecodeBMP(sBuffer)
		Dim lOffset
		Dim lNewWidth
		Dim lNewHeight
		Dim lBPP
		Dim lCompression
		Dim lImageSize
		Dim lTemp
		Dim lColourIndex
		Dim lPad
		Dim lLineSize
		Dim sLine
		Dim sBitmap
		
		' Check the magic number
		if MidB(sBuffer,1,2) = BitmapMagicNumber then
			lOffset = GetLong(MidB(sBuffer,11,4))
			lNewWidth = GetLong(MidB(sBuffer,19,4))
			lNewHeight = GetLong(MidB(sBuffer,23,4))
			lBPP = GetWord(MidB(sBuffer,29,2))
			lCompression = GetLong(MidB(sBuffer,31,4))
			lImageSize = GetLong(MidB(sBuffer,35,4))
			
			' Check the vital statistics of the image before proceeding
			' The criteria for the image is as follows:
			' 8 Bits per pixel
			' No compression
			if lBPP = 8 and lCompression = 0 then
				' Ok, so we have the header data for the bitmap, now we reformat the image
				' Image is resized, nothing is preserved
				Resize lNewWidth,lNewHeight,False
			
				lColourIndex = 0
				
				' Process the palette values, 256 RGBQUAD values in total
				For lTemp = 55 to 1079 Step 4
					GlobalColourTable(lColourIndex) = RGB(AscB(MidB(sBuffer,lTemp + 2,1)),AscB(MidB(sBuffer,lTemp + 1,1)),AscB(MidB(sBuffer,lTemp,1)))
					lColourIndex = lColourIndex + 1
				Next

				' Ok, we have width, height, and a valid colour table
				' now we read the bitmap data directly into the string array
				' all line lengths MUST be a multiple of 4, so we work out
				' the padding (if any)
				lPad = 4 - (lNewWidth Mod 4) ' We remove this many bytes from the end of each line

				if lPad = 4 then lPad = 0
				
				' Actual line width in the file
				lLineSize = lNewWidth + lPad
				
				' Bitmap information starts from the bottom line of the image and works
				' its way up
				sBitmap = MidB(sBuffer,lOffset + 1,lImageSize) ' Get the bitmap data

				' Reset sImage
				sImage = ""
				
				' Copy the data directly into the canvas, byte for byte
				For lTemp = 1 to LenB(sBitmap) Step lLineSize
					sImage = MidB(sBitmap,lTemp,lNewWidth) & sImage
				Next
			end if
		end if
	end function
	
	' Dump a 256 colour bitmap as an ASCII string of values
	public function EncodeBMP()
		Dim sTemp
		Dim lTemp
		Dim lImageSize
		Dim lFileSize
		Dim lPad
		Dim sBitmap
		Dim sPad
		
		sTemp = sTemp & MakeWord(0) ' Reserved (2)
		sTemp = sTemp & MakeWord(0) ' Reserved (2)
		sTemp = sTemp & MakeLong(1078) ' Offset (4)
		sTemp = sTemp & MakeLong(40) ' Headersize (4)
		sTemp = sTemp & MakeLong(lWidth) ' Width (4)
		sTemp = sTemp & MakeLong(lHeight) ' Height (4)
		sTemp = sTemp & MakeWord(1) ' Planes (2)
		sTemp = sTemp & MakeWord(8) ' BPP (2)
		sTemp = sTemp & MakeLong(0) ' Compression (4)

		lPad = 4 - (lWidth Mod 4)
		
		if lPad = 4 then lPad = 0
		
		lImageSize = (lWidth + lPad) * lHeight
		
		sTemp = sTemp & MakeLong(lImageSize) ' Image Size(4)
		
		sTemp = sTemp & MakeLong(0) ' Pixels per meter X (4)
		sTemp = sTemp & MakeLong(0) ' Pixels per meter Y (4)
		sTemp = sTemp & MakeLong(256) ' Colours used (4)
		sTemp = sTemp & MakeLong(256) ' Important colours (4)
		' RGBQUAD arrays (BGRX)
		For lTemp = 0 to UBound(GlobalColourTable) - 1
			sTemp = sTemp & MakeByte(Blue(GlobalColourTable(lTemp)))
			sTemp = sTemp & MakeByte(Green(GlobalColourTable(lTemp)))
			sTemp = sTemp & MakeByte(Red(GlobalColourTable(lTemp)))
			sTemp = sTemp & MakeByte(0) ' Pad
		Next
		' Image lines from the bottom up, padded to the closest 4 pixels
		
		sPad = ""
		' Make a pad for the end of each line
		for lTemp = 1 to lPad
			sPad = sPad & Chr(0)
		Next

		sBitmap = ""		
		' Do each line
		for lTemp = 1 to LenB(sImage) step lWidth
			sBitmap = MidB(sImage,lTemp,lWidth) & sPad & sBitmap
		next
		
		sTemp = sTemp & sBitmap
		
		lFileSize = LenB(sTemp) + 6

		' Magic number (2) and size of the file in bytes (4)		
		sTemp = BitmapMagicNumber & MakeLong(lFileSize) & sTemp
		
		EncodeBMP = sTemp
	end function


	private function DecimalToBinary(lNumber)
		Dim lTemp
		Dim bFound
		
		DecimalToBinary = ""
		
		bFound = False
		
		for lTemp = 7 to 0 step - 1
			if lNumber and 2^lTemp then
				DecimalToBinary = DecimalToBinary & "1"
				bFound = True
			elseif bFound then
				DecimalToBinary = DecimalToBinary & "0"
			end if
		next
		
		if DecimalToBinary = "" then DecimalToBinary = "0"
	end function

	private sub DumpBinary(sBlock,lBitLength,bClose)
		if bClose then
			Response.Write "<pre>"
		end if
		
		for lTemp = 1 to LenB(sBlock)
			' Write out the binary
			Response.Write " " 
			for lTemp2 = lBitLength-1 to 0 step -1
				if AscB(MidB(sBlock,lTemp,1)) and 2^lTemp2 then
					Response.Write "1"
				else
					Response.Write "0"
				end if
			next
			if lTemp Mod lBitLength = 0 then
				Response.Write "<br>"
			end if
		next
		
		if bClose then
			Response.Write "</pre>"
		end if
	end sub

	public sub WebSafePalette()
		' Reset the colours to the web safe palette
		Dim iTemp1
		Dim iTemp2
		Dim iTemp3
		Dim lIndex
		
		iIndex = 0
		
		For iTemp1 = &HFF0000& to 0 step - &H330000&
			For iTemp2 = &HFF00& to 0 step - &H3300&
				For iTemp3 = &HFF& to 0 step - &H33&
					GlobalColourTable(iIndex) = iTemp1 or iTemp2 or iTemp3
					iIndex = iIndex + 1
				Next
			Next
		Next
	end sub

	private sub Class_Initialize()
		sImage = "" ' Raster data

		GIF89a = False ' Default to 87a data

		ReDim GlobalColourTable(256) ' Start with a 256 colour global table
		lGlobalColourTableSize = 7
		bGlobalColourTableFlag = true

		ReDim LocalColourTable(0) ' No local table support yet
		lLocalColourTableSize = 0
		bLocalColourTableFlag = false

		' All the 7's
		lColourResolution = 7
		iBits = 7 ' Always 7 bit data (128 colours)
		lCodeSize = 7

		BackgroundColourIndex = 0
		
		BackgroundColourIndex = 0
		ForegroundColourIndex = 1
		TransparentColourIndex = 0
		UseTransparency = False

		lLeftPosition = 0
		lTopPosition = 0
		lWidth = INIT_WIDTH
		lHeight = INIT_HEIGHT
		
		Clear
		
		bytePixelAspectRatio = 0

		bSortFlag = false
		bInterlaceFlag = false

		byteSeperator = Asc(",")
		byteGraphicControl = Asc("!")
		byteEndOfImage = Asc(";")
		
		Comment = ""

		lReserved = 0
		bTest = FLAG_DEBUG
	end sub
	
	private sub Class_Terminate()
	end sub
End Class

' Pixel stack for certain pixel operations (like floodfill etc.)
Class PixelStack
	Private aPoints()
	
	Public Sub Push(lX,lY)
		' Add these coords to the stack
		ReDim Preserve aPoints(UBound(aPoints) + 1)
		
		set aPoints(UBound(aPoints)) = new Point
		
		aPoints(UBound(aPoints)).X = lX
		aPoints(UBound(aPoints)).Y = lY
	End Sub
	
	Public function Pop()
		' Get and remove the last coords from the stack
		Set Pop = aPoints(UBound(aPoints))
		
		ReDim Preserve aPoints(UBound(aPoints) - 1)
	End function
	
	Public Property Get Size()
		Size = UBound(aPoints)
	End Property
	
	Private Sub Class_Initialize()
		ReDim aPoints(0)
	End Sub
	
	Private Sub Class_Terminate()
	End Sub
End Class

' Simple point class
Class Point
	Public X
	Public Y
End Class

' ***************************************************************************
' ******************* Utility functions for this class **********************
' ***************************************************************************

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

function MakeLong(lValue)
	Dim lLowWord
	Dim lHighWord
	
	lLowWord = lValue and 65535
	lHighWord = ShiftRight(lValue,16) and 65535
	
	MakeLong = MakeWord(lLowWord) & MakeWord(lHighWord)
end function

' Get a number from a big-endian word
function GetWord(sValue)
	GetWord = ShiftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))
end function

' Make a big-endian word
function MakeWord(lValue)
	MakeWord = ChrB(Low(lValue)) & ChrB(High(lValue))
end function

' Filter out the high byte
function MakeByte(lValue)
	MakeByte = ChrB(Low(lValue))
end function

function Blue(lValue)
	Blue = Low(ShiftRight(lValue,16))
end function

function Green(lValue)
	Green = Low(ShiftRight(lValue,8))
end function

function Red(lValue)
	Red = Low(lValue)
end function

' Low byte order
function Low(lValue)
	Low = lValue and 255
end function

' High byte order
function High(lValue)
	High = ShiftRight(lValue,8)
end function

' Shift all bits left
function ShiftLeft(lValue,lBits)
	ShiftLeft = lValue * (2^lBits)
end function

' Shift all bits right
function ShiftRight(lValue,lBits)
	ShiftRight = int(lValue / (2^lBits))
end function

function DegreesToRadians(ByVal sinAngle)
	DegreesToRadians = sinAngle * (PI/180)
end function

function RadiansToDegrees(ByVal sinAngle)
	RadiansToDegrees = sinAngle * (180/PI)
end function
%>