Graduated fill for Rectangles

[GWS]

This subroutine ShadeRect() might come in useful occasionally ..

Code Select Expand



' Creative Basic Code
' GWS - October 2008
' Examples using a Graduated Shading Subroutine - ShadeRect()
'
def win:WINDOW
def wstyle,key,run:int

autodefine "off"

type colour
def red:int
def grn:int
def blu:int
endtype

def c1,c2:colour
def x,y,w,h,dw,flag:int
def r1,r2,g1,g2,b1,b2,numsteps:float

declare ShadeRect(x:int, y:int, width:int, height:int, c1:colour, c2:colour, flag:int)

wstyle = @SIZE|@MINBOX|@MAXBOX
window win,50,50,800,600,wstyle,0,"Shaded Rectangles",handler
setwindowcolor win,RGB(0,0,50)
centerwindow win

control win,"B, Exit, (800-70)/2, 480, 70, 35, 0, 1"

' First - a Horizontally shaded bar ..
' set rectangle position and size ..
w = 650: h = 40
x = 70: y = 60
' define start and end colours ..
c1.red = 50: c1.grn = 100: c1.blu = 60
c2.red = 255: c2.grn = 200: c2.blu = 160
' set flag = 1 for horizontal shading, flag = 0 for vertical shading ..
flag = 1
ShadeRect(x, y, w, h, c1, c2, flag)

' Next - a Vertically Shaded rectangle ..
w = 150: h = 300
x = 70: y = 110
' define start and end colours ..
c1.red = 0: c1.grn = 10: c1.blu = 160
c2.red = 0: c2.grn = 200: c2.blu = 190
' set flag = 1 for horizontal shading, flag = 0 for vertical shading ..
flag = 0
ShadeRect(x, y, w, h, c1, c2, flag)

' Then a Diagonally shaded square ..
w = 150: h = 150
x = 320: y = 110
' define start and end colours ..
c1.red = 200: c1.grn = 100: c1.blu = 60
c2.red = 50: c2.grn = 50: c2.blu = 190
' set flag = 1 for horizontal shading, flag = 0 for vertical shading ..
flag = 2
ShadeRect(x, y, w, h, c1, c2, flag)

' Lastly a Diagonally shaded Veertical rectangle ..
w = 150: h = 300
x = 570: y = 110
' define start and end colours ..
c1.red = 100: c1.grn = 100: c1.blu = 250
c2.red = 50: c2.grn = 250: c2.blu = 100
' set flag = 1 for horizontal shading, flag = 0 for vertical shading ..
flag = 2
ShadeRect(x, y, w, h, c1, c2, flag)


run = 1
waituntil run = 0
closewindow win
END

SUB handler
select @CLASS
case @IDCLOSEWINDOW
    run = 0
case @IDCHAR
' pressing the 'ESC'(ape) key will abort the program ...
    key = @CODE
if (key = 27) then run = 0
case @IDCONTROL
select @CONTROLID
case 1
run = 0
endselect
endselect
RETURN

sub ShadeRect(x, y, width, height, c1, c2, flag)
' routine to draw a shaded rectangle ..
def r,g,b:float
def rdel,gdel,bdel,xx,yy:float
def iw,ih,ic,grad:int
def x1,y1,x2,y2:int

' set the colour graduation ..
select flag
case 0
grad = height
case 1
grad = width
case 2
if (width > height)
grad = 2 * width
else
grad = 2 * height
endif
endselect

rdel=(c2.red - c1.red)/grad
gdel=(c2.grn - c1.grn)/grad
bdel=(c2.blu - c1.blu)/grad

r = c1.red
g = c1.grn
b = c1.blu

select flag
case 0
' vertical shading ..
for ih = 1 to height
line win,x,y+ih,x+width,y+ih,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next ih
case 1
' horizontal shading ..
for iw = 1 to width
line win,x+iw,y,x+iw,y+height,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next iw
case 2
' diagonal shading ..
select 1
case (width > height)
' horizontal rectangle ..
ic = 0
for iw = 0 to width
x1 = x + iw
y1 = y
if (iw < height)
x2 = x
y2 = y + iw
else
if (ic = 0) then ic = height
x2 = x + iw - ic
y2 = y + height
endif
line win, x1,y1,x2,y2,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next iw
for ih = 0 to height
line win,x+width,y+ih,x+width-height+ih,y+height,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next ih
case (width < height)
' vertical rectangle ..
ic = 0
for ih = 0 to height
x1 = x
y1 = y + ih
if (ih < width)
x2 = x + ih
y2 = y
else
if (ic = 0) then ic = width
x2 = x + width
y2 = y + ih - ic
endif
line win, x1,y1,x2,y2,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next ih
for iw = 0 to width
line win,x+iw,y+height,x+width,y+height-width+iw,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next iw
case (width = height)
' a square ..
for iw = 0 to width
line win,x+iw,y,x,y+iw,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next iw
for iw = 0 to width
line win,x+iw,y+height,x+width,y+iw,rgb(r,g,b)
r = r + rdel
g = g + gdel
b = b + bdel
next iw
endselect
endselect

return



Hope you like it .. 

Graham

[aurelCB]

Yeah,  who can say now that Creative is not powerfull enough?

[GWS]

Once bitten by the Creative bug, you never get over it .. 

Graham