Letter(0) = "000000000"
Letter(1) = "000000000"
Letter(2) = "000000000"
Letter(3) = "000000000"
Letter(4) = "000000000"
Letter(5) = "000000000"
Letter(6) = "000000000"
Letter(7) = "000000000"
Letter(8) = "000000000"
Letter(10) = "000111110"
Letter(11) = "001100110"
Letter(12) = "001100110"
Letter(13) = "011111100"
Letter(14) = "110001110"
Letter(15) = "110000110"
Letter(16) = "110000110"
Letter(17) = "110000110"
Letter(18) = "110000110"
Letter(19) = "110001100"
Letter(20) = "011011100"
Letter(21) = "011111000"
Letter(22) = "001110000"
Letter(23) = "000000000"
Letter(24) = "000000000"
Letter(25) = "000000000"
Letter(26) = "000000000"
Letter(27) = "000000000"
Letter(28) = "000000000"
Letter(29) = "000000000"
Font.Add "8", Letter
Letter(0) = "000000000"
Letter(1) = "000000000"
Letter(2) = "000000000"
Letter(3) = "000000000"
Letter(4) = "000000000"
Letter(5) = "000000000"
Letter(6) = "000000000"
Letter(7) = "000000000"
Letter(8) = "000000000"
Letter(9) = "000000000"
Letter(10) = "001111100"
Letter(11) = "011111110"
Letter(12) = "111000110"
Letter(13) = "110000110"
Letter(14) = "110001110"
Letter(15) = "110001110"
Letter(16) = "111111110"
Letter(17) = "011110110"
Letter(18) = "000001100"
Letter(19) = "000001100"
Letter(20) = "000111000"
Letter(21) = "000110000"
Letter(22) = "000000000"
Letter(23) = "000000000"
Letter(24) = "000000000"
Letter(25) = "000000000"
Letter(26) = "000000000"
Letter(27) = "000000000"
Letter(28) = "000000000"
Letter(29) = "000000000"
Font.Add "9", Letter
Letter(0) = "000000000"
Letter(1) = "000000000"
Letter(2) = "000000000"
Letter(3) = "000000000"
Letter(4) = "000000000"
Letter(5) = "000000000"
Letter(6) = "000000000"
Letter(7) = "000000000"
Letter(8) = "000000000"
Letter(9) = "000000000"
Letter(10) = "000000000"
Letter(11) = "000000000"
Letter(12) = "000000000"
Letter(13) = "000000000"
Letter(14) = "000000000"
Letter(15) = "000000000"
Letter(16) = "000000000"
Letter(17) = "000000000"
Letter(18) = "000000000"
Letter(19) = "000000000"
Letter(20) = "000000000"
Letter(21) = "000000000"
Letter(22) = "000000000"
Letter(23) = "000000000"
Letter(24) = "000000000"
Letter(25) = "000000000"
Letter(26) = "000000000"
Letter(27) = "000000000"
Letter(28) = "000000000"
Letter(29) = "000000000"
Font.Add " ", Letter
%>
建立canvas.asp文件
<%
' 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
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
相关专题
- asp检测文件编码 (0次浏览)
- ASP发送邮件的class(完) (0次浏览)
- Asp常见问题(新手) (0次浏览)
- asp编译成dll-图形化教程 (0次浏览)
- ASP编程入门进阶 (0次浏览)
- Asp备份与恢复SQL Server数据库 (0次浏览)
- Asp+的几个特点 (0次浏览)
- ASP：在结果中搜索 (0次浏览)
- asp 中对 ip 进行过滤限制函数 (0次浏览)
- ASP 指南 (0次浏览)
