Jump to content

Color wheel: Difference between revisions

Color wheel (view source)

Revision as of 20:54, 26 October 2022

1,416 bytes added ,  1 year ago
added image
(added image)
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.
<syntaxhighlight lang="vb">
optionOption explicit
 
Class ImgClass
Private ImgL,ImgH,ImgDepth,bkclr,nclrloc,tt
private xmini,xmaxi,ymini,ymaxi,dirx,diry
dimpublic ImgArray() 'rgb in 24 bit mode, indexes to palette in 8 bits
private filename
private Palette,szpal
public property get xmin():xmin=xmini:end property
public property get ymin():ymin=ymini:end property
public property get xmax():xmax=xmaxi:end property
public property get ymax():ymax=ymaxi:end property
public property let depth(x)
if x<>8 and x<>32 then err.raise 9
Imgdepth=x
end property
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
xmini=-x0
Line 1,527:
'constructor
Public Default Function Init(name,w,h,orient,dep,bkg,palmipal)
'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
dim ImgL=wi,j
ImgHImgL=hw
ImgH=h
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 'tlcorigin blc positive up and right
redim imgArray(ImgL-1,ImgH-1)
bkclr=bkg
if bkg<>0 then
for i=0 to ImgL-1
for j=0 to ImgH-1
imgarray(i,j)=bkg
next
next
end if
Select Case orient
filename=name
Case 1: dirx=1 : diry=1
Case 2: dirx=-1 : diry=1
'load user palette if provided
Case if3: imgdepthdirx=8-1 then: diry=-1
Case 4: dirx=1 if: isarray(pal) thendiry=-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
elseloadpal(mipal)
end if mypalette
set init=me
end if
end if
set init=me
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 ⟶ 1,581:
wscript.echo "copying image to bmp file"
savebmp
wscript.echo "opening " & filename & " with uouryour default bmp viewer"
CreateObject("Shell.Application").ShellExecute filename
wscript.echo timer-tt & " milliseconds iseconds"
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
Dim s,ostream, x,y,loc
dim bpp:bpp=imgdepth\8
const hdrs=54 '14+40
dim bms:bms=ImgH* 4*(((ImgL*bppimgdepth\8)+3)\4) 'bitmap size including padding
dim palspalsize:if (imgdepth=8) then palspalsize=(ubound(Palette)+1)szpal*4 else palspalsize=0
loc=getlocale
setlocale "us"
 
with CreateObject("ADODB.Stream") 'auxiliary ostream, it creates an UNICODE with bombbom stream in memory
.Charset = "WindowsUTF-125216LE" 'o "UTF16-BE"
.Type = 2' adTypeText
.open
Line 1,613:
'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
'BMP head 0 "BM" 'Type 2 size 6 10 14
.writetext "BM" & long2strChrW(hdrs+pals+bms)&h4d42) ' long2str(0) &long2str"BM" (hdrs+pals)4d42
.writetext long2wstr(hdrs+palsize+bms) ' 2 fiesize
 
'InfoHeader.writetext 14long2wstr(0) hdr sz 18 length 22 width 26 pla ' 6 28 clr depth 30 NOCOMPR 34reserved
.writetext long2str(40)long2wstr &long2str(Imgl)&long2str(imghhdrs+palsize) & int2str(1) & int2str(imgdepth)& long2str(&H0) '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
For y=y1 To y2 step diry
'wscript.echo imgdepth
For yx=ImgH-1 to 0 step-1 'Originx1 ofTo bitmap:x2 bottomStep leftdirx
s=""
For x=0 To ImgL-1
'writelong fic, Pixel(x,y)
s=s.writetext & long2strlong2wstr(Imgarray(x,y))
Next
.writetext s
Next
Case 8
dim xx:xx=ImgL mod 4'palette
For yx=ImgH-10 to 0 stepszpal-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
'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
WScript.Echo "ColorDepth not supported : " & ImgDepth & " bits"
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
outf.savetofile filename,2 'adSaveCreateOverWrite
outf.close
end with
setlocale loc
End Sub
end class
 
 
 
function hsv2rgb( Hue, Sat, Value) 'hue 0-360 0-ro 120-ver 240-az ,sat 0-100,value 0-100
Line 1,714 ⟶ 1,729:
g = Ur + (Vr - Wr) * Rdim
b = 0
end ifIf
'b lowest byte, red highest byte
hsv2rgb= ((b and &hff)+256*((g and &hff)+256*(r and &hff))and &hffffff)
 
end function
 
Line 1,740 ⟶ 1,755:
const r2=25500
tt=timer
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\testtestwchr.bmp"
Set X = (New ImgClass)(fn,w*2,h*2,1,32,0,0)
 
x.set0 w,h
Line 1,748 ⟶ 1,763:
for row=x.xmin+1 to x.xmax
row2=row*row
hr=int(sqrSqr(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
sat=100-sqr(row2+col*col)/rad *50
Line 1,756 ⟶ 1,776:
'script.echo row
next
 
Set X = Nothing
 
 
</syntaxhighlight>
=={{out}}==
[[File:Colorwheel vbs.png]]
 
=={{header|Wren}}==
Antoni Gual
38

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/332723"
Cookies help us deliver our services. By using our services, you agree to our use of cookies.
More information