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:
file: /Techref/language/asp/vbs/vbscript/imgClass.htm, 14KB, , updated: 2008/11/27 12:43, local time: 2024/8/14 19:21,
3.146.255.27:LOG IN
|
©2024 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? <A HREF="http://piclist.com/Techref/language/asp/vbs/vbscript/imgClass.htm"> VBScript Image Class - Create and manipulate bmp and pcx files </A> |
Did you find what you needed? |
![]() o List host: MIT, Site host massmind.org, Top posters @none found - 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 piclist.com! |
.