VBScript Image Class

Create and manipulate bmp and pcx files

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:

  .