please dont rip this site

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:

See also:


file: /Techref/language/asp/vbs/vbscript/imgClass.htm, 14KB, , updated: 2008/11/27 12:43, local time: 2017/10/17 09:36,
TOP NEW HELP FIND: 
54.92.141.211:LOG IN

 ©2017 These pages are served without commercial sponsorship. (No popup ads, etc...).Bandwidth abuse increases hosting cost forcing sponsorship or shutdown. This server aggressively defends against automated copying for any reason including offline viewing, duplication, etc... Please respect this requirement and DO NOT RIP THIS SITE. Questions?
Please DO link to this page! Digg it! / MAKE! / 

<A HREF="http://www.piclist.com/techref/language/asp/vbs/vbscript/imgClass.htm"> VBScript Image Class - Create and manipulate bmp and pcx files </A>

After you find an appropriate page, you are invited to your to this massmind site! (posts will be visible only to you before review) Just type in the box and press the Post button. (HTML welcomed, but not the <A tag: Instead, use the link box to link to another page. A tutorial is available Members can login to post directly, become page editors, and be credited for their posts.


Link? Put it here: 
if you want a response, please enter your email address: 
Attn spammers: All posts are reviewed before being made visible to anyone other than the poster.
Did you find what you needed?

  PICList 2017 contributors:
o List host: MIT, Site host massmind.org, Top posters @20171017 RussellMc, Van Horn, David, James Cameron, Sean Breheny, IVP, alan.b.pearce, Neil, David C Brown, Bob Blick, Denny Esterline,
* Page Editors: James Newton, David Cary, and YOU!
* Roman Black of Black Robotics donates from sales of Linistep stepper controller kits.
* Ashley Roll of Digital Nemesis donates from sales of RCL-1 RS232 to TTL converters.
* Monthly Subscribers: Gregg Rew. on-going support is MOST appreciated!
* Contributors: Richard Seriani, Sr.
 

Welcome to www.piclist.com!

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

  .