Graphical Class

Create/Alter pictures in pure WSH !

<?xml version="1.0" standalone="yes" ?>
<package>

<job id="IMG_Class">
<?job error="true" debug="true"?>
<script language="VBScript">
<![CDATA[
option explicit

'Interface of the graphical class
'Declaration : Set MyObj = New ImgClass
'Properties :
'	Palette(x) R/W, x=0..255, set/get an RGB code.
'	Width R/W Set/get the width of the picture. Resizing erases the picture
'	Height R/W set/get the height of the picture. Resizing erases the picture
'	Depth R/W set/get the color depth in bits. =8 ou 24. Decreasing alters the picture
'	Pixel(x,y) R/W, x=0..Width-1, y=0..Height-1. Get/set the color-code of a pixel.
'	QuickPixel(x,y) R/W, quicker than pixel : no clipping or depth control
'	NbColors R/W Get the nb of colors used in the picture, or decrease it
'Methodes :
'	ErasePic Clear the picture
'	GetRGB(r,g,b) Gets a color-code depending of the color depth : if 8bits : nearest color
'	Display Preview the picture with Internet Explorer
'	DisplayInfo Pops up a box with physicla picture properties
'	SaveBMP(Chemin_Complet) Save the picture to a BMP file
'	SavePCX(chemin_complet) Save the picture to a PCX file

Class ImgClass
	Private ImgL,ImgH,ImgDepth
	Private ImgMatrice() 'X,Y,(rgb)
	Private IE,TF	'DisplaySystem, TempFile

	Public Palette(255)'262144 colors => values=0..63 / composante

	Public Property Let Width (valeur)
		ImgL=valeur
		'Exit Property
		ErasePic
	End Property
	Public Property Get Width
		Width=ImgL
	End Property

	Public Property Let Height (valeur)
		ImgH=valeur
		'Exit Property
		ErasePic
	End Property
	Public Property Get Height
		Height=ImgH
	End Property

	Public Property Let Depth (valeur) '8 ou 24
		Dim x,y
		If Valeur=8 Then
			If ImgDepth<>8 Then 'If we will use a palette
				'indexes must not be greater than 256
				'#### There we should prefer to make a good palette and remap
				For y=0 To Height-1
					For x=0 To Width-1
						If ImgMatrice(x,y)>256 Then
							ImgMatrice(x,y)=ImgMatrice(x,y) Mod 256
						End If
					Next
				Next
			End If
		End If
		ImgDepth=Valeur
	End Property
	Public Property Get Depth
		Depth=ImgDepth
	End Property

	Public Property Let Pixel (x,y,color)
		If (x<ImgL) And (x>=0) And (y<ImgH) And (y>=0) Then 'Clipping
			Select Case Depth
			Case 24 'RGB
				ImgMatrice(x,y)=Color
			Case 8 'Index dans la palette
				ImgMatrice(x,y)=Color Mod 256
			Case Else
				WScript.Echo "ColorDepth unknown : " & Depth & " bits"
			End Select
		End If
	End Property
	Public Property Get Pixel (x,y)
		If (x<ImgL) And (x>=0) And (y<ImgH) And (y>=0) Then 'Clipping
			Pixel=ImgMatrice(x,y)
		End If
	End Property
	Public Property Let QuickPixel (x,y,color)
		ImgMatrice(x,y)=Color
	End Property
	Public Property Get QuickPixel (x,y)
		QuickPixel=ImgMatrice(x,y)
	End Property

	Public Sub ErasePic
		'Dim x,y,L,H
		'L=Width-1
		'H=Height-1 'out of the loop to speed up
		'For x=0 to L
		'	For y=0 To H
		'		ImgMatrice(x,y)=0
		'	Next
		'Next
		Redim ImgMatrice(ImgL-1,ImgH-1) 'Option Base 0
	End Sub

	Public Property Get NbColors
		Dim x,y,L,H,i,N,C,F
		Dim Colors()
		N=-1
		L=Width-1
		H=Height-1 'out of the loop to speed up
		For x=0 to L
			For y=0 To H
				C=ImgMatrice(x,y)
				F=False
				For i=0 to N	'Loop in the colors learned
					IF Colors(i)=C Then
						F=True
						Exit For
					End If
				Next
				If Not F Then
					N=N+1
					Redim Preserve Colors(N)
					Colors(N)=C
				End IF
			Next
		Next
		NbColors=N+1
	End Property
	Public Property Let NbColors (N)
		If N<Me.NbColors Then
			'######## To be done
			'Reduce the nb of colors only if needed
			WScript.Echo "Reducing nulber of colors from " & Me.NbColors & " to " & N
		End If
	End Property

	Private Sub Class_Initialize
		Dim i
		wscript.Echo "ImgClass started" & vbCrLf & chr(169) & "JLA 2001"
		For i=0 to 63
			Palette(i)=i*256*256+i*256+i
		Next
		For i=64 to 127
			Palette(i)=(i-64)*256*256+(127-i)
		Next
		For i=128 to 191
			Palette(i)=(i-128)+(191-i)*256
		Next
		For i=192 to 255
			Palette(i)=(i-192)*256+(255-i)*256*256
		Next
		Depth=8
		Width=0
		Height=0
	End Sub
	Private Sub Class_Terminate
		If TF<>"" Then
			'Kill the temp file
			Dim fso
			Set fso=CreateObject("Scripting.FileSystemObject")
			fso.DeleteFile(TF)
			Set fso=Nothing
		End If
		wscript.echo "ImgClass terminated" & vbCrLf & ScriptEngine & " Version " & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion
		If isObject(IE) Then
			On Error Resume Next
			ie.Quit
			Set IE=Nothing
		End If
	End Sub

	Public Function GetRGB(r,g,b)
		Dim i,r1,g1,b1,k,d,d2
		Select Case Depth
		Case 24
			GetRGB=r*256*256+g*256+b
		Case 8
			d2=256*256*256
			k=-1
			'Find the best color and return its index
			For i=0 To 255
				r1=Palette(i)
				b1=r1 Mod 256
				g1=r1\256
				r1=g1\256
				g1=g1 Mod 256
				d=abs(r-r1)*29+abs(g-g1)*60+abs(b-b1)*11
				If d<d2 Then	'Nearest color
					d2=d
					k=i
					If d=0 Then Exit For 'same color
				End If
			Next
			GetRGB=k
		Case Else
		End Select
	End Function
	Public Sub DisplayInfo
		Dim Info
		Info="Infos" & vbcrlf & "Width=" & Width & vbCrLf & "Height=" & Height
		Info=Info & vbCrLf & "Depth " & Depth & " bits"
		Info=Info & vbCrLf & "Nb of colors : " & NbColors
		Wscript.Echo Info
	End Sub
	Public Sub Display
		Dim L,H,F
		L=Width+30 '+ browser border
		If L>640 Then L=640 '######## To be done, get the screen width
		H=Height+32
		If H>480 Then H=480 '######### To be done, get the screen height
		F=True
		If isObject(IE) Then	'IE can be manually closed
			On Error Resume Next
			err.clear
			F=ie.Left
			F=(err.Number<>0)
			On Error Goto 0
			If F Then Set IE=Nothing
		End If
		If F Then
			Set IE = WScript.CreateObject("InternetExplorer.Application")
			ie.navigate "about:blank"
			While ie.busy
				WScript.Sleep 90
			Wend
			While IE.Document.readyState <> "complete"
				Wscript.Sleep 90
			Wend
			ie.menubar=0
			ie.toolbar=0
			ie.statusbar=0
			ie.document.title="Preview"
			ie.document.body.leftmargin=0
			ie.document.body.topmargin=0
		End If
		ie.left=(800-L)/2
		ie.top=(600-H)/2
		ie.height=H
		ie.width=L
		If TF="" Then	'TempFileName
			Dim fso
			Set fso=WScript.CreateObject("Scripting.FileSystemObject")
			TF=fso.BuildPath(fso.GetSpecialFolder(2).Path,fso.GetTempName) & ".bmp"
			Set fso=Nothing
		End If
		SaveBMP tf
		ie.document.body.innerhtml="<img src=""" & TF & """>"
		'ie.navigate tf
		ie.visible=1
	End Sub

	Sub WriteLong(ByRef Fic,ByVal k)
		Dim x
		For x=1 To 4
			Fic.Write chr(k Mod 256)
			k=k\256
		Next
	End Sub

	Public Sub SaveBMP(fichier)
		'Save the picture to a bmp file
		Const ForReading = 1 'f.skip(5)
		Const ForWriting = 2
		Const ForAppending = 8
		Dim fso,Fic
		Dim i,r,g,b
		Dim k,x,y,Pal,chaine

		Select Case Depth
		Case 24
			Pal=0
		Case 8
			Pal=1
		Case Else
			WScript.Echo "ColorDepth unknown : " & Depth & " bits"
			Exit Sub
		End Select

		Set fso=WScript.CreateObject("Scripting.FileSystemObject")
		Set Fic = fso.OpenTextFile(fichier, ForWriting, True)
		'FileHeader
		Fic.Write "BM" 'Type
		k=14+40+256*3*Pal+Height*((4-(Width Mod 4))mod 4)+Width*Height*Depth/8	'All headers included
		WriteLong Fic,k	'Size of entire file in bytes
		WriteLong Fic,0	'2 words. reserved, must be zero
		WriteLong Fic,54+Pal*1024	'2 words: offset of BITMAPFILEHEADER (access to the beginning of the bitmap) 54=14+40 (fileheader+infoheader)

		'InfoHeader
		WriteLong Fic,40	'Size of Info Header(40 bytes)
		WriteLong Fic,Width
		WriteLong Fic,Height
		Fic.Write chr(1) & chr(0) 'Planes : 1
		Fic.Write chr(Depth) & chr(0) 'Bitcount : 1,4,8,16,24,32 = bitsperpixel
		WriteLong Fic,0 'Compression 0=off, 1=8bits RLE, 2=4bits RLE
		WriteLong Fic,Height*((4-(Width Mod 4))mod 4)+Width*Height*Depth/8 'Sizeimage or 0 if not compressed. Depth/8=3 char/pix in 24 bits, =1 in 8 bits
		WriteLong Fic,3780 'XPelsPerMeter
		WriteLong Fic,3780 'YPelsPerMeter
		WriteLong Fic,0 'ClrUsed 0=all colors used
		WriteLong Fic,0 'ClrImportant 0=all colors are important
		If Pal=1 Then
			'Palette BGR0 sur 1024 octets
			For i=0 to 255
				b=Palette(i)
				g=b\256
				r=g\256
				Fic.Write chr((b Mod 64)*4) & chr((g Mod 64)*4) & chr((r Mod 64)*4) & chr(0)
			Next
		End If
		Chaine=""	'Padding mod 4
		If (Width Mod 4)<>0 then Chaine=String(4-Width Mod 4,chr(0))
		Select Case Depth
		Case 24
			For y=0 To Height-1
				For x=0 To Width-1
					k=Pixel(x,Height-y-1)	'Origin of bitmap: bottom left
					Fic.Write chr(k Mod 256)
					k=k\256
					Fic.Write chr(k Mod 256)
					k=k\256
					Fic.Write chr(k Mod 256)
				Next
				If Chaine <>"" Then Fic.Write Chaine
			Next
		Case 8
			For y=0 To Height-1
				For x=0 To Width-1
					Fic.Write chr(Pixel(x,Height-y-1))
				Next
				If Chaine <>"" Then Fic.Write Chaine
			Next
		Case Else
			WScript.Echo "ColorDepth unknown : " & Depth & " bits"
		End Select
		Fic.Close
		Set Fic=Nothing
		Set fso=Nothing
	End Sub

	Public Sub SavePCX(fichier)
		Const ForWriting = 2 'f.skip(5)
		Dim fso,Fic,i,r,v,b
		If Depth<>8 Then
			WScript.Echo "Invalid ColorDepth"
			Exit Sub
 		End If
		Set fso=WScript.CreateObject("Scripting.FileSystemObject")
		Set Fic = fso.OpenTextFile(fichier, ForWriting, True)
		'Header de 128 octets
		Fic.Write chr(10) & chr(5) & chr(1) & chr(8) 'Manufacturer, version, encoding, bitpix
		Fic.Write chr(0) & chr(0) 'Xmin
		Fic.Write chr(0) & chr(0) 'Ymin
		Fic.Write chr((Width-1) Mod 256) & chr((Width-1)\256) 'Xmax
		Fic.Write chr((Height-1) Mod 256) & chr((Height-1)\256) 'Ymax
		Fic.Write chr(Height Mod 256) & chr(Height\256) 'Hdpi
		Fic.Write chr(Width Mod 256) & chr(Width\256) 'Vdpi
		Fic.Write String(48,chr(0)) 'Colormap de 0 a 47
		Fic.Write chr(0) 'reserve
		Fic.Write chr(1) 'Nb Planes
		Fic.Write chr(Width Mod 256) & chr(Width\256) 'Byteslineplane
		Fic.Write chr(1) & chr(0) 'Paletteinfo
		Fic.Write chr(0) & chr(0) 'HScreenSize
		Fic.Write chr(0) & chr(0) 'VScreenSize
		Fic.Write String(127-74+1,chr(0)) 'Filer

		'Content compressed
		Dim octetimage,octetmem,compteur,pointeur,w,h,chaine
		w=Width-1
		h=Height-1
		For i=0 To h
			octetmem=imgMatrice(0,i)
			compteur=0
			Chaine=""
			For pointeur=1 to w 'le reste des points de la ligne
				octetimage=imgMatrice(pointeur,i)
				If (octetimage=octetmem) AND (compteur<62) Then
					compteur=compteur+1
				ELSE
					If octetmem<&HC0 Then
						If compteur>0 Then Chaine=Chaine & chr(compteur+&HC1)
						Chaine=Chaine & chr(octetmem)
					Else
						For b=0 To compteur
							Chaine=Chaine & chr(&HC1) & chr(octetmem)
						Next
					End If
					octetmem=octetimage
					compteur=0
				End If
			Next
			If octetmem<&HC0 Then
				If compteur>0 Then Chaine=Chaine & chr(compteur+&HC1)
				Chaine=Chaine & chr(octetmem)
			Else
				For b=0 To compteur
					Chaine=Chaine & chr(&HC1) & chr(octetmem)
				Next
			End If
			Fic.Write Chaine
		Next

		' tell that a palette is present
		Fic.Write chr(12)

		'Palette
		For i=0 to 255
			b=Palette(i)
			v=b\256
			r=v\256
			v=v mod 256
			b=b mod 256
			Fic.Write chr(r*4) & chr(v*4) & chr(b*4)
		Next

		Fic.Close
		Set Fic=Nothing
		Set fso=Nothing
    End Sub
End Class

Dim X,i,j
Set X = New ImgClass
x.Width=80
x.Height=60
'x.ErasePic 'unnecessary because erased while sizing
x.Pixel(9,10)=127
x.Pixel(9,11)=255
For i=0 to 63
	x.Pixel(i,1)=x.GetRGB(i,0,0)
	x.Pixel(i,2)=x.GetRGB(0,i,0)
	x.Pixel(i,3)=x.GetRGB(0,0,i)
	x.Pixel(i,4)=x.GetRGB(i,0,i)
	x.Pixel(i,5)=x.GetRGB(i,i,0)
	x.Pixel(i,6)=x.GetRGB(0,i,i)
	x.Pixel(i,7)=x.GetRGB(i,i,i)
Next
'x.SavePCX("d:\temp\jl.pcx")
'x.NbColors=5

'x.Width=18
'x.Height=18
'x.Depth=24
'x.ErasePic
'for j=0 to x.height-1
'	for i=0 to x.width-1
'		x.Pixel(i,j)=256*256*256-1
'	next
'next
x.pixel(1,1)=x.getrgb(0,0,255)
x.pixel(1,2)=x.getrgb(0,255,0)
x.pixel(1,3)=x.getrgb(255,0,0)

'x.SaveBMP("d:\temp\jl.bmp")
x.Display
x.DisplayInfo
Set X = Nothing

]]>
</script>
</job>

</package>