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
ImgMatrice(x,y)=Color
Case 8
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
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
ReDim Palette(255)
For i=0 to 63
Palette(i)=CLng(i*256*256+i*256+i)
Next
For i=64 to 127
Palette(i)=CLng((i-64)*256*256+(127-i))
Next
For i=128 to 191
Palette(i)=CLng((i-128)+(191-i)*256)
Next
For i=192 to 255
Palette(i)=CLng((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
' Example:
Dim X
Set X = New ImgClass
x.Width=80
x.Height=60
Dim i,j
for i = 10 to 20
for j = 2 to 50
x.Pixel(i,j)=127
next
next
x.SaveBMP("c:\red_on_black.bmp")
x.Display
x.DisplayInfo
Set X = Nothing
Comments: