Graphical Class

Create/Alter pictures in pure WSH !

Yes, you can now manipulate pictures or create them in VBS without having to register third party components.
Just use this class and create your bitmaps in just a few lines.

File Name : img.wsf
Requirement : IE optional
Author : Jean-Luc Antoine
Submitted : 22/09/2001
Category : Class
<?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>
Server Info
Remote Info
Compress

Batchs
BootSector
Droit
Accessoire GFA
On Now
Ecran plasma
Système d'exploitation
Son
Unités
Scripting
Multilingue
Site Web
Bruit et son
Architecture Google


4K
Color picker
TaskList
Backup files
Mini Port Scanner
Website To CHM
PixyDemo
Web password recovery
4KWebServer
Kill Popup
VBE decoder
Script Optimizer
Database Password Recovery
Class
Ini
EMail validator
Graphical Class
MP3 Info
Pinger Class
IP ranger class
SoftwareMetering
Path Validator
Time Stamper Class
LoggerCLS
HTA
Keyword Ranking
DOM Explorer
HTA-Notepad
PixyPortManager
Other
flashMessage
Kill Popup
VBE decoder (fixed)
Error Codes
Maze generator
Char counter
HTML To Word
ICQ Choose User
ScreenSaver Password decoder
Mp3Playlister - singleList
Long Filename To Short
Trace Math
Dump Hexa File
Self modifying script
Mp3Playlister - multiList
HTANoid
PixyWebServer
Python
Progress indication

©2002 Jean-Luc Antoine. All Rights Reserved. Scripts or any other material on this website may not be redistributed or put as part of ANY collection (script archives, CDs etc) without prior written permission. Permission granted to use and modify any of the scripts found on InterClasse.com