?? 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"))
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -