Color wheel: Difference between revisions

Content added Content deleted
(added image)
Line 1,500: Line 1,500:
Building a BMP file and opening it with the default viewer. It takes 5 seconds in my 5 years old notebook. Run with Cscript if you don want to be clicking at annoying message boxes.
Building a BMP file and opening it with the default viewer. It takes 5 seconds in my 5 years old notebook. Run with Cscript if you don want to be clicking at annoying message boxes.
<syntaxhighlight lang="vb">
<syntaxhighlight lang="vb">
option explicit
Option explicit


Class ImgClass
Class ImgClass
Private ImgL,ImgH,ImgDepth,bkclr,nclr,tt
Private ImgL,ImgH,ImgDepth,bkclr,loc,tt
private xmini,xmaxi,ymini,ymaxi
private xmini,xmaxi,ymini,ymaxi,dirx,diry
dim ImgArray() 'rgb in 24 bit mode, indexes to palette in 8 bits
public ImgArray() 'rgb in 24 bit mode, indexes to palette in 8 bits
private filename
private filename
private Palette
private Palette,szpal
public property get xmin():xmin=xmini:end property
public property get xmin():xmin=xmini:end property
public property get ymin():ymin=ymini:end property
public property get ymin():ymin=ymini:end property
public property get xmax():xmax=xmaxi:end property
public property get xmax():xmax=xmaxi:end property
public property get ymax():ymax=ymaxi:end property
public property get ymax():ymax=ymaxi:end property
public property let depth(x)
public property let depth(x)
if x<>8 and x<>32 then err.raise 9
if x<>8 and x<>32 then err.raise 9
Imgdepth=x
Imgdepth=x
end property
end property
public sub set0 (x0,y0) 'sets the new origin (default tlc)
public sub set0 (x0,y0) 'sets the new origin (default tlc). The origin does'nt work if ImgArray is accessed directly
if x0<0 or x0>=imgl or y0<0 or y0>imgh then err.raise 9
if x0<0 or x0>=imgl or y0<0 or y0>imgh then err.raise 9
xmini=-x0
xmini=-x0
Line 1,527: Line 1,527:
'constructor
'constructor
Public Default Function Init(name,w,h,dep,bkg,pal)
Public Default Function Init(name,w,h,orient,dep,bkg,mipal)
'offx, offy posicion de 0,0. si ofx+ , x se incrementa de izq a der, si offy+ y se incrementa de abajo arriba
dim i,j
ImgL=w
dim i,j
ImgH=h
ImgL=w
ImgH=h
tt=timer
tt=timer
loc=getlocale
depth=dep
' not useful as we are not using SetPixel and accessing ImgArray directly
if dep<>8 and dep <>32 then err.raise 9
set0 0,0 'tlc
set0 0,0 'origin blc positive up and right
redim imgArray(ImgL-1,ImgH-1)
redim imgArray(ImgL-1,ImgH-1)
bkclr=bkg
bkclr=bkg
if bkg<>0 then
if bkg<>0 then
for i=0 to ImgL-1
for i=0 to ImgL-1
for j=0 to ImgH-1
for j=0 to ImgH-1
imgarray(i,j)=bkg
imgarray(i,j)=bkg
next
next
next
next
end if
end if
Select Case orient
filename=name
Case 1: dirx=1 : diry=1
Case 2: dirx=-1 : diry=1
'load user palette if provided
if imgdepth=8 then
Case 3: dirx=-1 : diry=-1
if isarray(pal) then
Case 4: dirx=1 : diry=-1
End select
if ubound(pal)=255 then
filename=name
palette=pal
ImgDepth =dep
else
'load user palette if provided
mypalette
if imgdepth=8 then
end if
else
loadpal(mipal)
mypalette
end if
set init=me
end if
end if
set init=me
end function
end function

private sub loadpal(mipale)
if isarray(mipale) Then
palette=mipale
szpal=UBound(mipale)+1
Else
szpal=256
'Default palette recycled from ATARI
'removed

, not relevant
End if
End Sub


Line 1,570: Line 1,581:
wscript.echo "copying image to bmp file"
wscript.echo "copying image to bmp file"
savebmp
savebmp
wscript.echo "opening " & filename & " with uour default viewer"
wscript.echo "opening " & filename & " with your default bmp viewer"
CreateObject("Shell.Application").ShellExecute filename
CreateObject("Shell.Application").ShellExecute filename
wscript.echo timer-tt & " milliseconds"
wscript.echo timer-tt & " iseconds"
End Sub
End Sub
function long2wstr( x) 'falta muy poco!!!
dim k1,k2,x1
k1= (x and &hffff&)' or (&H8000& And ((X And &h8000&)<>0)))
k2=((X And &h7fffffff&) \ &h10000&) Or (&H8000& And (x<0))
long2wstr=chrw(k1) & chrw(k2)
end function
function int2wstr(x)
int2wstr=ChrW((x and &h7fff) or (&H8000 And (X<0)))
End Function




Public Sub SaveBMP
function long2str(byval k)
Dim s
s= chr(k and &hff)
k=k\&h100
s=s& chr(k and &hff)
k=k\&h100
s=s& chr(k and &hff)
k=k\&h100
s=s& chr(k and &hff)
long2str=s
End function
function int2str(byval k)
Dim s
s= chr(k and &hff)
k=k\&h100
s=s& chr(k and &hff)
int2str=s
End function
Public Sub SaveBMP
'Save the picture to a bmp file
'Save the picture to a bmp file
Dim s,ostream, x,y,loc
Dim s,ostream, x,y,loc
dim bpp:bpp=imgdepth\8
const hdrs=54 '14+40
const hdrs=54 '14+40
dim bms:bms=ImgH* 4*(((ImgL*bpp)+3)\4) 'bitmap size including padding
dim bms:bms=ImgH* 4*(((ImgL*imgdepth\8)+3)\4) 'bitmap size including padding
dim pals:if (imgdepth=8) then pals=(ubound(Palette)+1)*4 else pals=0
dim palsize:if (imgdepth=8) then palsize=szpal*4 else palsize=0
loc=getlocale
setlocale "us"


with CreateObject("ADODB.Stream") 'auxiliary ostream, it creates an UNICODE with bomb stream in memory
with CreateObject("ADODB.Stream") 'auxiliary ostream, it creates an UNICODE with bom stream in memory
.Charset = "Windows-1252"
.Charset = "UTF-16LE" 'o "UTF16-BE"
.Type = 2' adTypeText
.Type = 2' adTypeText
.open
.open
Line 1,613: Line 1,613:
'build a header
'build a header
'bmp header: VBSCript does'nt have records nor writes binary values to files, so we use strings of unicode chars!!
'bmp header: VBSCript does'nt have records nor writes binary values to files, so we use strings of unicode chars!!
'BMP header
'BMP head 0 "BM" 'Type 2 size 6 10 14
.writetext "BM" & long2str(hdrs+pals+bms)& long2str(0) &long2str (hdrs+pals)
.writetext ChrW(&h4d42) ' 0 "BM" 4d42
.writetext long2wstr(hdrs+palsize+bms) ' 2 fiesize

'InfoHeader 14 hdr sz 18 length 22 width 26 pla 28 clr depth 30 NOCOMPR 34
.writetext long2wstr(0) ' 6 reserved
.writetext long2str(40) &long2str(Imgl)&long2str(imgh) & int2str(1) & int2str(imgdepth)& long2str(&H0)
.writetext long2wstr (hdrs+palsize) '10 image offset
'InfoHeader
.writetext long2wstr(40) '14 infoheader size
.writetext long2wstr(Imgl) '18 image length
.writetext long2wstr(imgh) '22 image width
.writetext int2wstr(1) '26 planes
.writetext int2wstr(imgdepth) '28 clr depth (bpp)
.writetext long2wstr(&H0) '30 compression used 0= NOCOMPR
.writetext long2wstr(bms) '34 imgsize
.writetext long2wstr(&Hc4e) '38 bpp hor
.writetext long2wstr(&hc43) '42 bpp vert
.writetext long2wstr(szpal) '46 colors in palette
.writetext long2wstr(&H0) '50 important clrs 0=all
'write bitmap
'precalc data for orientation
Dim x1,x2,y1,y2
If dirx=-1 Then x1=ImgL-1 :x2=0 Else x1=0:x2=ImgL-1
If diry=-1 Then y1=ImgH-1 :y2=0 Else y1=0:y2=ImgH-1
Select Case imgdepth
' 34 nosize 38 bpp 42 bpp 46 cls pal 50 imp clrs 54
.writetext long2str(bms)&long2str(&Hc4e)& long2str(&hc43)& long2str(&H0) & long2str(&H0)

'add palette if exists
If (imgdepth=8) Then
s=""
For x=0 to ubound(palette)
s=s& long2str(palette(x))
Next
.writetext s
End If
'write bitmap
Select Case ImgDepth
Case 32
Case 32
For y=y1 To y2 step diry
'wscript.echo imgdepth
For y=ImgH-1 to 0 step-1 'Origin of bitmap: bottom left
For x=x1 To x2 Step dirx
s=""
For x=0 To ImgL-1
'writelong fic, Pixel(x,y)
'writelong fic, Pixel(x,y)
s=s & long2str(Imgarray(x,y))
.writetext long2wstr(Imgarray(x,y))
Next
Next
.writetext s
Next
Next
Case 8
Case 8
dim xx:xx=ImgL mod 4
'palette
For y=ImgH-1 to 0 step-1
For x=0 to szpal-1
s=""
.writetext long2wstr(palette(x)) '52
For x=0 To ImgL-1 step 2
s=s & chrw((ImgArray(x,y) and 255 )+ 256*(ImgArray(x+1,y) and 255))
Next
if xx and 1 then s=s &chrw(ImgArray(Imgl-1,y))
if xx >1 then s=s & chrw(0)
.writetext s
Next
Next
'image
dim pad:pad=ImgL mod 4
For y=y1 to y2 step diry
For x=x1 To x2 step dirx*2
.writetext chrw((ImgArray(x,y) and 255)+ &h100& *(ImgArray(x+dirx,y) and 255))
Next
'line padding
if pad and 1 then .writetext chrw(ImgArray(x2,y))
if pad >1 then .writetext chrw(0)
Next
Case Else
Case Else
WScript.Echo "ColorDepth not supported : " & ImgDepth & " bits"
WScript.Echo "ColorDepth not supported : " & ImgDepth & " bits"
End Select
End Select


'use a second stream to save to file starting past the BOM the first ADODB.Stream has added
'save to file
Dim outf:Set outf= CreateObject("ADODB.Stream")
.position=0 'using single byte chars, no bom
outf.Type = 1 ' adTypeBinary
.savetofile filename,2 'adSaveCreateOverWrite
outf.Open
.position=2 'remove bom (1 wchar)
.CopyTo outf
.close
.close
outf.savetofile filename,2 'adSaveCreateOverWrite
outf.close
end with
end with
setlocale loc
End Sub
End Sub
end class
end class




function hsv2rgb( Hue, Sat, Value) 'hue 0-360 0-ro 120-ver 240-az ,sat 0-100,value 0-100
function hsv2rgb( Hue, Sat, Value) 'hue 0-360 0-ro 120-ver 240-az ,sat 0-100,value 0-100
Line 1,714: Line 1,729:
g = Ur + (Vr - Wr) * Rdim
g = Ur + (Vr - Wr) * Rdim
b = 0
b = 0
end if
end If
'b lowest byte, red highest byte
hsv2rgb= ((b and &hff)+256*((g and &hff)+256*(r and &hff))and &hffffff)
hsv2rgb= ((b and &hff)+256*((g and &hff)+256*(r and &hff))and &hffffff)

end function
end function


Line 1,740: Line 1,755:
const r2=25500
const r2=25500
tt=timer
tt=timer
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\test.bmp"
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\testwchr.bmp"
Set X = (New ImgClass)(fn,w*2,h*2,32,0,0)
Set X = (New ImgClass)(fn,w*2,h*2,1,32,0,0)


x.set0 w,h
x.set0 w,h
Line 1,748: Line 1,763:
for row=x.xmin+1 to x.xmax
for row=x.xmin+1 to x.xmax
row2=row*row
row2=row*row
hr=int(sqr(r2-row2))
hr=int(Sqr(r2-row2))
For col=hr To 159
Dim a:a=((col\16 +row\16) And 1)* &hffffff
x.imgArray(col+160,row+160)=a
x.imgArray(-col+160,row+160)=a
next
for col=-hr to hr
for col=-hr to hr
sat=100-sqr(row2+col*col)/rad *50
sat=100-sqr(row2+col*col)/rad *50
Line 1,756: Line 1,776:
'script.echo row
'script.echo row
next
next

Set X = Nothing
Set X = Nothing


</syntaxhighlight>
</syntaxhighlight>
=={{out}}==
[[File:Colorwheel vbs.png]]


=={{header|Wren}}==
=={{header|Wren}}==
Retrieved from "https://rosettacode.org/wiki/Color_wheel"