264 lines
7.6 KiB
VB.net
264 lines
7.6 KiB
VB.net
option explicit
|
|
|
|
' Raster graphics class in VBSCRIPT by Antoni Gual
|
|
'--------------------------------------------
|
|
' An array keeps the image allowing to set pixels, draw lines and boxes in it.
|
|
' at class destroy a bmp file is saved to disk and the default viewer is called
|
|
' The class can work with 8 and 24 bit bmp. With 8 bit uses a built-in palette or can import a custom one
|
|
|
|
|
|
'Declaration :
|
|
' Set MyObj = (New ImgClass)(name,width,height, orient,bits_per_pixel,palette_array)
|
|
' name:path and name of the file created
|
|
' width, height of the canvas
|
|
' orient is the way the coord increases, 1 to 4 think of the 4 cuadrants of the caterian plane
|
|
' 1 X:l>r Y:b>t 2 X:r>l Y:b>t 3 X:r>l Y:t>b 4 X:l>r Y:t>b
|
|
' bits_per_pixel can bs only 8 and 24
|
|
' palette array only to substitute the default palette for 8 bits, else put a 0
|
|
' it sets the origin at the corner of the image (bottom left if orient=1)
|
|
|
|
Class ImgClass
|
|
Private ImgL,ImgH,ImgDepth,bkclr,loc,tt
|
|
private xmini,xmaxi,ymini,ymaxi,dirx,diry
|
|
public ImgArray() 'rgb in 24 bit mode, indexes to palette in 8 bits
|
|
private filename
|
|
private Palette,szpal
|
|
|
|
Public Property Let depth (x)
|
|
if depth=8 or depth =24 then
|
|
Imgdepth=depth
|
|
else
|
|
Imgdepth=8
|
|
end if
|
|
bytepix=imgdepth/8
|
|
end property
|
|
|
|
Public Property Let Pixel (x,y,color)
|
|
If (x>=ImgL) or x<0 then exit property
|
|
if y>=ImgH or y<0 then exit property
|
|
ImgArray(x,y)=Color
|
|
End Property
|
|
|
|
Public Property Get Pixel (x,y)
|
|
If (x<ImgL) And (x>=0) And (y<ImgH) And (y>=0) Then
|
|
Pixel=ImgArray(x,y)
|
|
End If
|
|
End Property
|
|
|
|
Public Property Get ImgWidth ()
|
|
ImgWidth=ImgL-1
|
|
End Property
|
|
|
|
Public Property Get ImgHeight ()
|
|
ImgHeight=ImgH-1
|
|
End Property
|
|
|
|
'constructor (fn,w*2,h*2,32,0,0)
|
|
Public Default Function Init(name,w,h,orient,dep,bkg,mipal)
|
|
'offx, offy posicion de 0,0. si ofx+ , x se incrementa de izq a der, si offy+ y se incrementa de abajo arriba
|
|
dim i,j
|
|
ImgL=w
|
|
ImgH=h
|
|
tt=timer
|
|
set0 0,0 'origin blc positive up and right
|
|
redim imgArray(ImgL-1,ImgH-1)
|
|
bkclr=bkg
|
|
if bkg<>0 then
|
|
for i=0 to ImgL-1
|
|
for j=0 to ImgH-1
|
|
imgarray(i,j)=bkg
|
|
next
|
|
next
|
|
end if
|
|
Select Case orient
|
|
Case 1: dirx=1 : diry=1
|
|
Case 2: dirx=-1 : diry=1
|
|
Case 3: dirx=-1 : diry=-1
|
|
Case 4: dirx=1 : diry=-1
|
|
End select
|
|
filename=name
|
|
ImgDepth =dep
|
|
'load user palette if provided
|
|
if imgdepth=8 then
|
|
loadpal(mipal)
|
|
end if
|
|
set init=me
|
|
end function
|
|
|
|
private sub loadpal(mipale)
|
|
if isarray(mipale) Then
|
|
palette=mipale
|
|
szpal=UBound(mipale)+1
|
|
Else
|
|
szpal=256
|
|
'Default palette recycled from ATARI
|
|
|
|
End if
|
|
End Sub
|
|
public sub set0 (x0,y0) 'origin can be changed during drawing
|
|
if x0<0 or x0>=imgl or y0<0 or y0>imgh then err.raise 9
|
|
xmini=-x0
|
|
ymini=-y0
|
|
xmaxi=xmini+imgl-1
|
|
ymaxi=ymini+imgh-1
|
|
|
|
end sub
|
|
|
|
|
|
Private Sub Class_Terminate
|
|
if err <>0 then wscript.echo "Error " & err.number
|
|
wscript.echo "writing bmp to file"
|
|
savebmp
|
|
wscript.echo "opening " & filename
|
|
CreateObject("Shell.Application").ShellExecute filename
|
|
wscript.echo timer-tt & " seconds"
|
|
End Sub
|
|
|
|
|
|
'writes a 32bit integr value as binary to an utf16 string
|
|
function long2wstr( x) 'falta muy poco!!!
|
|
dim k1,k2,x1
|
|
k1= (x and &hffff&)' or (&H8000& And ((X And &h8000&)<>0)))
|
|
k2=((X And &h7fffffff&) \ &h10000&) Or (&H8000& And (x<0))
|
|
long2wstr=chrw(k1) & chrw(k2)
|
|
end function
|
|
|
|
function int2wstr(x)
|
|
int2wstr=ChrW((x and &h7fff) or (&H8000 And (X<0)))
|
|
End Function
|
|
|
|
|
|
Public Sub SaveBMP
|
|
'Save the picture to a bmp file
|
|
Dim s,ostream, x,y,loc
|
|
|
|
const hdrs=54 '14+40
|
|
dim bms:bms=ImgH* 4*(((ImgL*imgdepth\8)+3)\4) 'bitmap size including padding
|
|
dim palsize:if (imgdepth=8) then palsize=szpal*4 else palsize=0
|
|
|
|
with CreateObject("ADODB.Stream") 'auxiliary ostream, it creates an UNICODE with bom stream in memory
|
|
.Charset = "UTF-16LE" 'o "UTF16-BE"
|
|
.Type = 2' adTypeText
|
|
.open
|
|
|
|
'build a header
|
|
'bmp header: VBSCript does'nt have records nor writes binary values to files, so we use strings of unicode chars!!
|
|
'BMP header
|
|
.writetext ChrW(&h4d42) ' 0 "BM" 4d42
|
|
.writetext long2wstr(hdrs+palsize+bms) ' 2 fiesize
|
|
.writetext long2wstr(0) ' 6 reserved
|
|
.writetext long2wstr (hdrs+palsize) '10 image offset
|
|
'InfoHeader
|
|
.writetext long2wstr(40) '14 infoheader size
|
|
.writetext long2wstr(Imgl) '18 image length
|
|
.writetext long2wstr(imgh) '22 image width
|
|
.writetext int2wstr(1) '26 planes
|
|
.writetext int2wstr(imgdepth) '28 clr depth (bpp)
|
|
.writetext long2wstr(&H0) '30 compression used 0= NOCOMPR
|
|
|
|
.writetext long2wstr(bms) '34 imgsize
|
|
.writetext long2wstr(&Hc4e) '38 bpp hor
|
|
.writetext long2wstr(&hc43) '42 bpp vert
|
|
.writetext long2wstr(szpal) '46 colors in palette
|
|
.writetext long2wstr(&H0) '50 important clrs 0=all
|
|
|
|
'write bitmap
|
|
'precalc data for orientation
|
|
Dim x1,x2,y1,y2
|
|
If dirx=-1 Then x1=ImgL-1 :x2=0 Else x1=0:x2=ImgL-1
|
|
If diry=-1 Then y1=ImgH-1 :y2=0 Else y1=0:y2=ImgH-1
|
|
|
|
Select Case imgdepth
|
|
|
|
Case 32
|
|
For y=y1 To y2 step diry
|
|
For x=x1 To x2 Step dirx
|
|
'writelong fic, Pixel(x,y)
|
|
.writetext long2wstr(Imgarray(x,y))
|
|
Next
|
|
Next
|
|
|
|
Case 8
|
|
'palette
|
|
For x=0 to szpal-1
|
|
.writetext long2wstr(palette(x)) '52
|
|
Next
|
|
'image
|
|
dim pad:pad=ImgL mod 4
|
|
For y=y1 to y2 step diry
|
|
For x=x1 To x2 step dirx*2
|
|
.writetext chrw((ImgArray(x,y) and 255)+ &h100& *(ImgArray(x+dirx,y) and 255))
|
|
Next
|
|
'line padding
|
|
if pad and 1 then .writetext chrw(ImgArray(x2,y))
|
|
if pad >1 then .writetext chrw(0)
|
|
Next
|
|
|
|
Case Else
|
|
WScript.Echo "ColorDepth not supported : " & ImgDepth & " bits"
|
|
End Select
|
|
|
|
'use a second stream to save to file starting past the BOM the first ADODB.Stream has added
|
|
Dim outf:Set outf= CreateObject("ADODB.Stream")
|
|
outf.Type = 1 ' adTypeBinary
|
|
outf.Open
|
|
.position=2 'remove bom (1 wchar)
|
|
.CopyTo outf
|
|
.close
|
|
outf.savetofile filename,2 'adSaveCreateOverWrite
|
|
outf.close
|
|
end with
|
|
End Sub
|
|
End Class
|
|
|
|
function mandelpx(x0,y0,maxit)
|
|
dim x,y,xt,i,x2,y2
|
|
i=0:x2=0:y2=0
|
|
Do While i< maxit
|
|
i=i+1
|
|
xt=x2-y2+x0
|
|
y=2*x*y+y0
|
|
x=xt
|
|
x2=x*x:y2=y*y
|
|
If (x2+y2)>=4 Then Exit do
|
|
loop
|
|
if i=maxit then
|
|
mandelpx=0
|
|
else
|
|
mandelpx = i
|
|
end if
|
|
end function
|
|
|
|
Sub domandel(x1,x2,y1,y2)
|
|
Dim i,ii,j,jj,pix,xi,yi,ym
|
|
ym=X.ImgHeight\2
|
|
'get increments in the mandel plane
|
|
xi=Abs((x1-x2)/X.ImgWidth)
|
|
yi=Abs((y2-0)/(X.ImgHeight\2))
|
|
j=0
|
|
For jj=0. To y2 Step yi
|
|
i=0
|
|
For ii=x1 To x2 Step xi
|
|
pix=mandelpx(ii,jj,256)
|
|
'use simmetry
|
|
X.imgarray(i,ym-j)=pix
|
|
X.imgarray(i,ym+j)=pix
|
|
i=i+1
|
|
Next
|
|
j=j+1
|
|
next
|
|
End Sub
|
|
|
|
'main------------------------------------
|
|
Dim i,x
|
|
'custom palette
|
|
dim pp(255)
|
|
for i=1 to 255
|
|
pp(i)=rgb(0,0,255*(i/255)^.25) 'VBS' RGB function is for the web, it's bgr for Windows BMP !!
|
|
next
|
|
|
|
dim fn:fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\mandel.bmp"
|
|
Set X = (New ImgClass)(fn,580,480,1,8,0,pp)
|
|
domandel -2.,1.,-1.2,1.2
|
|
Set X = Nothing
|